Polish monopam CLI: unified output, distinct exit codes, bug fixes

+80 -29

bin/cmd_add.ml

··· 1 1 open Cmdliner 2 2 3 + (** Parse the positional argument. A [.lock] suffix always means lock file; a 4 + URL-ish string is a direct Git_url; anything else is treated as an opam 5 + package name to be resolved against the local overlay or [opam show]. *) 6 + type parsed = Parsed of Monopam.Import.source | Opam_name of string 7 + 3 8 let parse_source source = 4 9 if String.ends_with ~suffix:".lock" source then 5 - Monopam.Import.Lock_file (Fpath.v source) 10 + Parsed (Monopam.Import.Lock_file (Fpath.v source)) 6 11 else 7 - (* Parse opam URL syntax: URL#ref *) 8 - let url, ref_ = 9 - match String.rindex_opt source '#' with 12 + (* Split opam URL syntax: URL#ref *) 13 + let split_at_hash s = 14 + match String.rindex_opt s '#' with 10 15 | Some i -> 11 - let url = String.sub source 0 i in 12 - let ref_ = String.sub source (i + 1) (String.length source - i - 1) in 13 - (url, Some ref_) 14 - | None -> (source, None) 16 + let u = String.sub s 0 i in 17 + let r = String.sub s (i + 1) (String.length s - i - 1) in 18 + (u, Some r) 19 + | None -> (s, None) 15 20 in 16 - Monopam.Import.Git_url { url; branch = None; ref_ } 21 + if Monopam.Import.looks_like_url source then 22 + let url, ref_ = split_at_hash source in 23 + Parsed (Monopam.Import.Git_url { url; branch = None; ref_ }) 24 + else 25 + (* Plain opam package name. Defer resolution to the main runner 26 + where we have access to [fs] and a process manager. *) 27 + let name, _ref = split_at_hash source in 28 + Opam_name name 29 + 30 + (** Best-effort: find the opam-repo directory associated with the current 31 + workspace, so we can resolve package names against the local overlay before 32 + shelling out to [opam show]. If the config cannot be loaded, skip the 33 + overlay path and rely on [opam show] alone. *) 34 + let local_opam_repo env = 35 + match Common.load_config env with 36 + | Ok config -> Some (Monopam.Config.Paths.opam_repo config) 37 + | Error _ -> None 38 + 39 + let resolve_if_name env proc fs source = 40 + match parse_source source with 41 + | Parsed s -> Ok s 42 + | Opam_name name -> ( 43 + let opam_repo = local_opam_repo env in 44 + let fs = (fs :> Eio.Fs.dir_ty Eio.Path.t) in 45 + match Monopam.Import.resolve_name ~proc ~fs ?opam_repo name with 46 + | Ok url -> 47 + Fmt.pr "[add] resolved %s to %s@." name url; 48 + Ok (Monopam.Import.Git_url { url; branch = None; ref_ = None }) 49 + | Error msg -> Error msg) 17 50 18 51 let run source dir dry_run () = 52 + let t0 = Unix.gettimeofday () in 19 53 Eio_main.run @@ fun env -> 20 54 let fs = Eio.Stdenv.fs env in 21 55 let proc = Eio.Stdenv.process_mgr env in 22 56 let target = Fpath.v (Sys.getcwd ()) in 23 - let source = parse_source source in 24 57 Eio.Switch.run @@ fun sw -> 25 - match 26 - Monopam.Import.run ~sw ~proc ~fs ~target ~source ~name:dir ~dry_run () 27 - with 28 - | Ok results -> 29 - if results = [] then Fmt.pr "Nothing added.@." 30 - else begin 31 - Fmt.pr "Added %d subtree%s:@." (List.length results) 32 - (if List.length results = 1 then "" else "s"); 33 - List.iter 34 - (fun r -> 35 - Fmt.pr " %s (%s)@." r.Monopam.Import.name 36 - (String.sub r.Monopam.Import.commit 0 37 - (min 7 (String.length r.Monopam.Import.commit)))) 38 - results 39 - end; 40 - `Ok () 41 - | Error e -> 42 - Fmt.epr "Error: %s@." e; 43 - `Error (false, "add failed") 58 + match resolve_if_name env proc fs source with 59 + | Error msg -> 60 + let hint = 61 + "Pass a git URL (e.g. https://github.com/owner/repo.git) or install \ 62 + the package first so `opam show` can locate its dev-repo field." 63 + in 64 + Common.fail_ctx (Monopam.Ctx.err ~hint msg) 65 + | Ok source -> ( 66 + match 67 + Monopam.Import.run ~sw ~proc ~fs ~target ~source ~name:dir ~dry_run () 68 + with 69 + | Ok results -> 70 + let elapsed = Unix.gettimeofday () -. t0 in 71 + if results = [] then Common.print_success ~elapsed "Nothing to add." 72 + else begin 73 + List.iter 74 + (fun r -> 75 + let short = 76 + String.sub r.Monopam.Import.commit 0 77 + (min 7 (String.length r.Monopam.Import.commit)) 78 + in 79 + Fmt.pr " + %s (%s)@." r.Monopam.Import.name short) 80 + results; 81 + let n = List.length results in 82 + let msg = 83 + Fmt.str "Added %d subtree%s." n (if n = 1 then "" else "s") 84 + in 85 + Common.print_success ~elapsed ~next_step:"dune build && dune test" 86 + msg 87 + end; 88 + `Ok () 89 + | Error e -> 90 + let hint = 91 + "Check that the URL is a git repository you can reach, or pass the \ 92 + opam URL syntax (URL#ref) to pin a specific revision." 93 + in 94 + Common.fail_ctx (Monopam.Ctx.err ~hint e)) 44 95 45 96 let man = 46 97 [

+1 -3

bin/cmd_clean.ml

··· 41 41 Eio.Switch.run @@ fun sw -> 42 42 match Monopam.Clean.run ~sw ~proc ~fs ~config ~dry_run ~force () with 43 43 | Ok () -> `Ok () 44 - | Error e -> 45 - Fmt.epr "Error: %a@." Monopam.Ctx.pp_error_with_hint e; 46 - `Error (false, "clean failed") 44 + | Error e -> Common.fail_ctx e 47 45 in 48 46 Cmd.v info 49 47 Term.(ret (const run $ dry_run_arg $ force_arg $ Common.logging_term))

+5 -2

bin/cmd_deps.ml

··· 13 13 match Monopam.Deps.run ~sw ~proc ~fs ~target ~dry_run () with 14 14 | Ok () -> `Ok () 15 15 | Error e -> 16 - Fmt.epr "Error: %s@." e; 17 - `Error (false, "deps failed") 16 + let hint = 17 + "Verify the sources listed in sources.toml are reachable and that you \ 18 + have not already imported them with a different name." 19 + in 20 + Common.fail_ctx (Monopam.Ctx.err ~hint e) 18 21 19 22 let man = 20 23 [

+14 -12

bin/cmd_diff.ml

··· 27 27 | Error _ -> false 28 28 else false 29 29 30 - let run package incoming () = 30 + let run packages incoming () = 31 31 Eio_main.run @@ fun env -> 32 32 Common.with_config env @@ fun config -> 33 33 let fs = Eio.Stdenv.fs env in 34 34 Eio.Switch.run @@ fun sw -> 35 35 match Monopam.status ~sw ~fs:(fs :> Eio.Fs.dir_ty Eio.Path.t) ~config () with 36 - | Error e -> 37 - Fmt.epr "Error: %a@." Monopam.pp_error_with_hint e; 38 - `Error (false, "diff failed") 36 + | Error e -> Common.fail_ctx e 39 37 | Ok statuses -> 40 38 let statuses = 41 - match package with 42 - | Some name -> 39 + match packages with 40 + | [] -> statuses 41 + | names -> 43 42 List.filter 44 - (fun s -> Monopam.Package.name s.Monopam.Status.package = name) 43 + (fun s -> 44 + List.mem (Monopam.Package.name s.Monopam.Status.package) names) 45 45 statuses 46 - | None -> statuses 47 46 in 48 47 if statuses = [] then begin 49 - (match package with 50 - | Some name -> Fmt.epr "Package not found: %s@." name 51 - | None -> Fmt.epr "No packages found@."); 48 + (match packages with 49 + | [] -> Fmt.epr "No packages found@." 50 + | names -> 51 + Fmt.epr "Package%s not found: %s@." 52 + (if List.length names = 1 then "" else "s") 53 + (String.concat ", " names)); 52 54 `Error (false, "no packages") 53 55 end 54 56 else begin ··· 90 92 in 91 93 Cmd.v info 92 94 Term.( 93 - ret (const run $ Common.package_arg $ incoming_arg $ Common.logging_term)) 95 + ret (const run $ Common.packages_arg $ incoming_arg $ Common.logging_term))

+1 -3

bin/cmd_fetch.ml

··· 47 47 let proc = Eio.Stdenv.process_mgr env in 48 48 Eio.Switch.run @@ fun sw -> 49 49 match Monopam.Ctx.status ~sw ~fs ~config () with 50 - | Error e -> 51 - Fmt.epr "Error: %a@." Monopam.Ctx.pp_error_with_hint e; 52 - `Error (false, "fetch failed") 50 + | Error e -> Common.fail_ctx e 53 51 | Ok statuses -> 54 52 let statuses = 55 53 match package with

+16 -19

bin/cmd_init.ml

··· 2 2 3 3 let root_arg = 4 4 let doc = 5 - "Path to workspace root directory. Defaults to current directory." 5 + "Path to workspace root directory. Defaults to the current directory." 6 6 in 7 7 Arg.( 8 8 value ··· 53 53 | None -> Error "Need --handle or a sources.toml with origin field") 54 54 55 55 let run root handle dry_run () = 56 + let t0 = Unix.gettimeofday () in 56 57 Eio_main.run @@ fun env -> 57 58 let fs = Eio.Stdenv.fs env in 58 59 let proc = Eio.Stdenv.process_mgr env in 59 60 Eio.Switch.run @@ fun sw -> 60 - let git_toplevel () = 61 - try 62 - let buf = Buffer.create 128 in 63 - Eio.Process.run proc ~stdout:(Eio.Flow.buffer_sink buf) 64 - [ "git"; "rev-parse"; "--show-toplevel" ]; 65 - let s = Buffer.contents buf |> String.trim in 66 - match Fpath.of_string s with Ok p -> Some p | Error _ -> None 67 - with Eio.Io _ -> None 68 - in 61 + (* Resolve target before any side effects. No magic: use --root if 62 + given, otherwise the current working directory. We print the 63 + resolved path so the user knows exactly where init will write. *) 69 64 let target = 70 - match root with 71 - | Some r -> r 72 - | None -> ( 73 - match git_toplevel () with 74 - | Some p -> p 75 - | None -> Fpath.v (Sys.getcwd ())) 65 + match root with Some r -> r | None -> Fpath.v (Sys.getcwd ()) 76 66 in 67 + Fmt.pr "[init] root: %a@." Fpath.pp target; 77 68 (* Step 1: Resolve identity *) 78 69 match resolve_handle ~fs handle target with 79 70 | Error msg -> 80 - Fmt.epr "Error: %s@." msg; 81 - `Error (false, "init failed") 71 + let hint = 72 + "Pass --handle alice.bsky.social to set your identity, or create a \ 73 + sources.toml with an `origin` field in the workspace root." 74 + in 75 + Common.fail_ctx (Monopam.Ctx.err ~hint msg) 82 76 | Ok resolved_handle -> 83 77 Fmt.pr "[init] handle: %s@." resolved_handle; 84 78 (* Step 2: Verse workspace setup (idempotent) *) ··· 95 89 | Error e -> Fmt.pr "[init] bootstrap: %s@." e); 96 90 (* Step 4: Regenerate root deps (dune-project + root.opam) *) 97 91 Monopam.Import.update_root_deps ~fs ~target; 98 - Fmt.pr "[init] done.@."; 92 + let elapsed = Unix.gettimeofday () -. t0 in 93 + Common.print_success ~elapsed 94 + ~next_step:"monopam add <git-url> # or: monopam pull" 95 + "Workspace initialized."; 99 96 `Ok () 100 97 101 98 let man =

+6 -2

bin/cmd_publish.ml

··· 24 24 ~no_commit ~dry_run () 25 25 with 26 26 | Error (`Config_error e) -> 27 - Fmt.epr "Error: %s@." e; 28 - `Error (false, "publish failed") 27 + let hint = 28 + "The opam-repo directory must exist and be a git repository. Pass \ 29 + --opam-repo PATH to point at a different location, or run `monopam \ 30 + init` to bootstrap one." 31 + in 32 + Common.fail_ctx (Monopam.Ctx.err ~hint e) 29 33 | Ok opam_result -> 30 34 Fmt.pr "%a@." Monopam.Opam_sync.pp opam_result; 31 35 (match config_opt with

+3 -9

bin/cmd_pull.ml

··· 41 41 match Monopam.Pull.run ~sw ~proc ~fs ~config ~packages () with 42 42 | Ok () -> 43 43 let elapsed = Unix.gettimeofday () -. t0 in 44 - Fmt.pr "@.%a Monorepo updated in %a.@." Tty.Span.pp 45 - (Tty.Span.styled Tty.Style.(fg Tty.Color.green) "✓") 46 - Tty.Span.pp 47 - (Tty.Span.styled 48 - Tty.Style.(fg Tty.Color.cyan) 49 - (Fmt.str "%.1fs" elapsed)); 44 + Common.print_success ~elapsed ~next_step:"dune build && dune test" 45 + "Monorepo updated."; 50 46 `Ok () 51 - | Error e -> 52 - Fmt.epr "Error: %a@." Monopam.Ctx.pp_error_with_hint e; 53 - `Error (false, "pull failed") 47 + | Error e -> Common.fail_ctx e 54 48 in 55 49 Cmd.v info Term.(ret (const run $ Common.packages_arg $ Common.logging_term))

+35 -38

bin/cmd_push.ml

··· 4 4 [ 5 5 `S Manpage.s_description; 6 6 `P 7 - "Exports changes from your monorepo to upstream git repositories. Each \ 8 - subdirectory is split into an independent commit history and pushed to \ 9 - its upstream remote."; 7 + "Exports changes from your monorepo to the git remotes configured for \ 8 + each subtree. By design those remotes are repositories you own — \ 9 + typically your forks — so push is always safe: monopam never writes to \ 10 + someone else's canonical repo."; 10 11 `S "WORKFLOW"; 11 12 `P "After making and committing changes in mono/:"; 12 13 `Pre ··· 14 15 git add -A && git commit -m \"Add feature\"\n\ 15 16 monopam push"; 16 17 `S "WHAT IT DOES"; 17 - `I ("1.", "Validates that the monorepo has no uncommitted changes"); 18 18 `I 19 - ( "2.", 19 + ( "1.", 20 20 "For each package, extracts the subtree commit history using tree-hash \ 21 21 projection. Only commits that actually change the subtree are \ 22 22 included; commits that modify other packages are skipped." ); 23 23 `I 24 - ( "3.", 24 + ( "2.", 25 25 "Pushes the split history to local checkouts (src/). If the checkout \ 26 26 has diverged (e.g. after filter-repo or a split algorithm change) but \ 27 27 its tree is a subset of the new split, the push auto-forces. If the \ 28 28 checkout has content not in the monorepo, push fails — pull first." ); 29 - `I ("4.", "Pushes checkouts to their upstream git remotes."); 29 + `I 30 + ( "3.", 31 + "Pushes each checkout to its configured remote (the URL from \ 32 + sources.toml or the package's dev-repo)." ); 30 33 `S "COMMIT METADATA"; 31 34 `P 32 35 "Split commits preserve the original author, committer, date, and \ 33 36 message from the monorepo. This means the split history is a faithful \ 34 37 projection of the monorepo history onto each subtree."; 35 38 `P 36 - "If multiple monorepos include the same upstream project, each will \ 37 - produce its own split history. The upstream repo accepts pushes from \ 38 - any monorepo as long as they fast-forward from the current HEAD. \ 39 - Conflict resolution happens at the monorepo level: pull upstream \ 40 - changes, resolve conflicts, then push back."; 39 + "If multiple monorepos include the same source project, each will \ 40 + produce its own split history. The remote accepts pushes from any \ 41 + monorepo as long as they fast-forward from the current HEAD. Conflict \ 42 + resolution happens at the monorepo level: pull the new changes, resolve \ 43 + conflicts, then push back."; 41 44 `S "OPTIONS"; 42 45 `I 43 46 ( "--local", ··· 49 52 commits." ); 50 53 `I 51 54 ( "--force", 52 - "Force push to upstream remotes. Use when the upstream has diverged \ 53 - (e.g. someone pushed directly to the upstream repo). Does not affect \ 54 - local checkout pushes, which auto-force when safe." ); 55 + "Force push to remotes. Use when the remote has diverged (e.g. someone \ 56 + pushed directly). Does not affect local checkout pushes, which \ 57 + auto-force when safe." ); 55 58 `S Manpage.s_examples; 56 - `P "Push all changes to upstream:"; 59 + `P "Push all changes to your remotes:"; 57 60 `Pre "monopam push"; 58 61 `P "Push changes for a specific package:"; 59 62 `Pre "monopam push mylib"; 60 63 `P "Export without pushing (for review):"; 61 64 `Pre "monopam push --local"; 62 - `P "Force push after upstream diverged:"; 65 + `P "Force push after the remote diverged:"; 63 66 `Pre "monopam push --force mylib"; 64 67 ] 65 68 66 69 let local_arg = 67 70 let doc = 68 - "Only export to checkouts, don't push to remotes. Use to review changes." 71 + "Only export to checkouts under src/. Skip the git push to each subtree's \ 72 + configured remote. Use this to review the split commits locally (e.g. \ 73 + with `git log src/<repo>`) before sending them out." 69 74 in 70 75 Arg.(value & flag & info [ "local" ] ~doc) 71 76 ··· 78 83 79 84 let force_arg = 80 85 let doc = 81 - "Force push to upstream remotes. Use when the upstream repo has diverged \ 82 - (e.g. someone pushed directly). Local checkout pushes auto-force when \ 83 - safe (tree containment check)." 86 + "Force push to configured remotes. Use when the remote has diverged (e.g. \ 87 + someone pushed directly). Local checkout pushes auto-force when safe \ 88 + (tree containment check)." 84 89 in 85 90 Arg.(value & flag & info [ "force" ] ~doc) 86 91 87 - let pp_success ~local_only ~elapsed = 88 - if local_only then 89 - Fmt.pr "@.%a Changes exported to checkouts in %a.@." Tty.Span.pp 90 - (Tty.Span.styled Tty.Style.(fg Tty.Color.green) "✓") 91 - Tty.Span.pp 92 - (Tty.Span.styled Tty.Style.(fg Tty.Color.cyan) (Fmt.str "%.1fs" elapsed)) 93 - else 94 - Fmt.pr "@.%a Changes pushed to upstream in %a.@." Tty.Span.pp 95 - (Tty.Span.styled Tty.Style.(fg Tty.Color.green) "✓") 96 - Tty.Span.pp 97 - (Tty.Span.styled Tty.Style.(fg Tty.Color.cyan) (Fmt.str "%.1fs" elapsed)) 98 - 99 92 let run packages ~local_only ~clean ~force () = 100 93 let t0 = Unix.gettimeofday () in 101 94 Eio_main.run @@ fun env -> ··· 109 102 with 110 103 | Ok () -> 111 104 let elapsed = Unix.gettimeofday () -. t0 in 112 - pp_success ~local_only ~elapsed; 105 + let msg, next = 106 + if local_only then 107 + ( "Changes exported to checkouts.", 108 + "monopam push # to send to your remotes" ) 109 + else ("Changes pushed to your remotes.", "monopam status") 110 + in 111 + Common.print_success ~elapsed ~next_step:next msg; 113 112 `Ok () 114 - | Error e -> 115 - Fmt.epr "Error: %a@." Monopam.Ctx.pp_error_with_hint e; 116 - `Error (false, "push failed") 113 + | Error e -> Common.fail_ctx e 117 114 118 115 let cmd = 119 - let doc = "Push local changes to upstream repositories" in 116 + let doc = "Push local changes to your configured remotes" in 120 117 let info = Cmd.info "push" ~doc ~man in 121 118 Cmd.v info 122 119 Term.(

+19 -13

bin/cmd_status.ml

··· 14 14 `I ("local:=", "Monorepo and checkout are in sync"); 15 15 `I 16 16 ( "local:+N", 17 - "Monorepo has N commits not yet in checkout (run $(b,monopam sync))" ); 17 + "Monorepo has N commits not yet in checkout (run $(b,monopam push \ 18 + --local))" ); 18 19 `I 19 20 ( "local:-N", 20 - "Checkout has N commits not yet in monorepo (run $(b,monopam sync))" ); 21 - `I ("local:sync", "Trees differ, needs sync (run $(b,monopam sync))"); 21 + "Checkout has N commits not yet in monorepo (run $(b,monopam pull))" ); 22 + `I 23 + ( "local:sync", 24 + "Trees differ — run $(b,monopam pull) then $(b,monopam push) to \ 25 + reconcile" ); 22 26 `S "REMOTE SYNC INDICATORS"; 23 27 `I ("remote:=", "Checkout and upstream remote are in sync"); 24 - `I 25 - ( "remote:+N", 26 - "Checkout has N commits to push (run $(b,monopam sync --remote))" ); 27 - `I ("remote:-N", "Upstream has N commits to pull (run $(b,monopam sync))"); 28 + `I ("remote:+N", "Checkout has N commits to push (run $(b,monopam push))"); 29 + `I ("remote:-N", "Upstream has N commits to pull (run $(b,monopam pull))"); 28 30 `I ("remote:+N/-M", "Diverged: checkout +N ahead, upstream +M ahead"); 29 31 `S "FORK ANALYSIS"; 30 32 `P "If tracking other members via verse, shows fork comparison:"; ··· 34 36 `I ("~", "Not in your workspace (use --all to list)"); 35 37 `S "NEXT STEPS"; 36 38 `P "Based on the status output:"; 37 - `I ("local:+N or local:-N", "Run $(b,monopam sync) to synchronize"); 38 - `I ("remote:-N", "Run $(b,monopam sync) to pull upstream changes"); 39 - `I ("remote:+N", "Run $(b,monopam sync --remote) to push to upstream"); 39 + `I 40 + ( "local:-N", 41 + "Run $(b,monopam pull) to bring checkout commits into the monorepo" ); 42 + `I 43 + ( "local:+N", 44 + "Run $(b,monopam push --local) to export monorepo commits to checkouts" 45 + ); 46 + `I ("remote:-N", "Run $(b,monopam pull) to fetch upstream changes"); 47 + `I ("remote:+N", "Run $(b,monopam push) to send commits upstream"); 40 48 ] 41 49 42 50 let abbrev_handle h = ··· 125 133 end; 126 134 if show_forks then print_forks ~sw ~proc ~fs ~config ~show_all; 127 135 `Ok () 128 - | Error e -> 129 - Fmt.epr "Error: %a@." Monopam.pp_error_with_hint e; 130 - `Error (false, "status failed") 136 + | Error e -> Common.fail_ctx e 131 137 132 138 let cmd = 133 139 let doc = "Show synchronization status of all packages" in

+11 -14

bin/cmd_verse.ml

··· 50 50 ~refresh () 51 51 with 52 52 | Ok result -> handle_pull_result result handle 53 - | Error e -> 54 - Fmt.epr "Error: %a@." Monopam.pp_error_with_hint e; 55 - `Error (false, "pull failed") 53 + | Error e -> Common.fail_ctx e 56 54 57 55 let pull_run handle repo refresh () = 58 56 Eio_main.run @@ fun env -> ··· 158 156 (const (fun arg refresh patch () -> diff_run arg ~refresh ~patch ()) 159 157 $ diff_arg $ diff_refresh_arg $ diff_patch_arg $ Common.logging_term)) 160 158 161 - (* verse cherrypick - cherry-pick specific commit *) 159 + (* verse cherry-pick - cherry-pick specific commit. Hyphenated to match 160 + git's own vocabulary. *) 162 161 let cherrypick_cmd = 163 162 let doc = "Cherry-pick a specific commit from a verse member" in 164 163 let man = ··· 170 169 `S "WORKFLOW"; 171 170 `I ("1.", "$(b,monopam verse diff) - See available commits"); 172 171 `I ("2.", "$(b,monopam verse diff <sha>) - View the patch"); 173 - `I ("3.", "$(b,monopam verse cherrypick <sha>) - Apply that commit"); 172 + `I ("3.", "$(b,monopam verse cherry-pick <sha>) - Apply that commit"); 174 173 `I ("4.", "$(b,monopam push) - Push changes upstream"); 175 174 `S Manpage.s_examples; 176 175 `P "Cherry-pick a commit:"; 177 - `Pre "monopam verse cherrypick abc1234"; 176 + `Pre "monopam verse cherry-pick abc1234"; 178 177 ] 179 178 in 180 - let info = Cmd.info "cherrypick" ~doc ~man in 179 + let info = Cmd.info "cherry-pick" ~doc ~man in 181 180 let sha_arg = 182 181 let doc = "The commit SHA (or prefix) to cherry-pick (at least 7 chars)." in 183 182 Arg.(required & pos 0 (some string) None & info [] ~docv:"SHA" ~doc) ··· 194 193 Fmt.pr "%a" Monopam.pp_cherrypick_result result; 195 194 Fmt.pr "Run $(b,monopam push) to publish this change.@."; 196 195 `Ok () 197 - | Error e -> 198 - Fmt.epr "Error: %a@." Monopam.pp_error_with_hint e; 199 - `Error (false, "cherrypick failed") 196 + | Error e -> Common.fail_ctx e 200 197 in 201 198 let run sha refresh () = 202 199 Eio_main.run @@ fun env -> ··· 281 278 members; 282 279 `Ok () 283 280 | Error e -> 284 - Fmt.epr "Error: %a@." Monopam.Verse.pp_error_with_hint e; 285 - `Error (false, "members failed") 281 + let msg = Fmt.str "%a" Monopam.Verse.pp_error_with_hint e in 282 + Common.fail_ctx (Monopam.Ctx.err msg) 286 283 in 287 284 Cmd.v info Term.(ret (const run $ Common.logging_term)) 288 285 ··· 372 369 handle_fork_success ~fs ~config ~dry_run result; 373 370 `Ok () 374 371 | Error e -> 375 - Fmt.epr "Error: %a@." Monopam.Verse.pp_error_with_hint e; 376 - `Error (false, "fork failed") 372 + let msg = Fmt.str "%a" Monopam.Verse.pp_error_with_hint e in 373 + Common.fail_ctx (Monopam.Ctx.err msg) 377 374 378 375 let fork_cmd = 379 376 let doc = "Fork a package from a verse member" in

+51 -8

bin/common.ml

··· 24 24 let doc = "Package names. If not specified, operates on all packages." in 25 25 Arg.(value & pos_all string [] & info [] ~docv:"PACKAGE" ~doc) 26 26 27 + (** {1 Unified success output} *) 28 + 29 + (** [print_success ?next_step ~elapsed msg] emits a green ✓ with a short 30 + message, a cyan elapsed-time span, and an optional "Next: ..." hint. Every 31 + successful command terminal output flows through here so the user learns a 32 + single visual grammar: 33 + {v 34 + ✓ Changes pushed. (0.1s) 35 + Next: monopam status 36 + v} *) 37 + let print_success ?next_step ~elapsed msg = 38 + let check = Tty.Span.styled Tty.Style.(fg Tty.Color.green) "✓" in 39 + let timing = 40 + Tty.Span.styled Tty.Style.(fg Tty.Color.cyan) (Fmt.str "%.1fs" elapsed) 41 + in 42 + Fmt.pr "%a %s (%a)@." Tty.Span.pp check msg Tty.Span.pp timing; 43 + match next_step with 44 + | None -> () 45 + | Some hint -> 46 + let arrow = Tty.Span.styled Tty.Style.(fg Tty.Color.cyan) "Next:" in 47 + Fmt.pr " %a %s@." Tty.Span.pp arrow hint 48 + 49 + (** [fail_ctx e] prints [e] with its hint and terminates the process with the 50 + matching exit code ([Ctx.exit_code]). Commands call this from their Error 51 + branches so shell scripts can distinguish user errors, network issues, 52 + conflicts, and external service failures. *) 53 + let fail_ctx e = 54 + Fmt.epr "Error: %a@." Monopam.Ctx.pp_error_with_hint e; 55 + exit (Monopam.Ctx.exit_code e) 56 + 27 57 (* Load config from opamverse.toml *) 28 58 let load_config env = 29 59 let fs = Eio.Stdenv.fs env in ··· 32 62 let with_config env f = 33 63 match load_config env with 34 64 | Ok config -> f config 35 - | Error msg -> 36 - Fmt.epr "Error loading config: %s@." msg; 37 - Fmt.epr "Run 'monopam init' first to create a workspace.@."; 38 - `Error (false, "configuration error") 65 + | Error err -> 66 + let hint = 67 + match err with 68 + | Monopam.Config.Not_found _ -> 69 + "Run 'monopam init --handle <your-handle>' to create a workspace." 70 + | Monopam.Config.Invalid { path; _ } -> 71 + Fmt.str 72 + "Your config at %a is malformed. Fix the TOML syntax, or delete \ 73 + the file and re-run 'monopam init'." 74 + Fpath.pp path 75 + | Monopam.Config.Io_error { path; _ } -> 76 + Fmt.str "Check the permissions of %a." Fpath.pp path 77 + in 78 + let msg = Fmt.str "%a" Monopam.Config.pp_load_error err in 79 + fail_ctx (Monopam.Ctx.err ~hint msg) 39 80 40 81 (* Helper to load verse config from XDG *) 41 82 let with_verse_config env f = 42 83 let fs = Eio.Stdenv.fs env in 43 84 match Monopam.Verse_config.load ~fs () with 44 85 | Ok config -> f config 45 - | Error msg -> 46 - Fmt.epr "Error loading opamverse config: %s@." msg; 47 - Fmt.epr "Run 'monopam init' to create a workspace.@."; 48 - `Error (false, "configuration error") 86 + | Error err -> 87 + let hint = "Run 'monopam init --handle <your-handle>' to set up verse." in 88 + let msg = 89 + Fmt.str "loading verse config: %a" Monopam.Config.pp_load_error err 90 + in 91 + fail_ctx (Monopam.Ctx.err ~hint msg)

+16 -8

bin/main.ml

··· 8 8 [ 9 9 `S Manpage.s_description; 10 10 `P 11 - "$(b,monopam) manages OCaml packages in a monorepo structure. It syncs \ 12 - your monorepo with upstream git repositories."; 11 + "$(b,monopam) manages OCaml packages in a monorepo structure. Each \ 12 + subdirectory is a subtree from an external git repository. You edit \ 13 + everything in one tree, then use $(b,pull) and $(b,push) to move \ 14 + changes in and out."; 15 + `P 16 + "$(b,pull) fetches from upstream sources. $(b,push) writes to your own \ 17 + configured remotes — monopam never pushes to someone else's canonical \ 18 + repo."; 13 19 `S "QUICK START"; 14 20 `P "Initialize a new workspace:"; 15 21 `Pre "monopam init --handle yourname.bsky.social"; 16 22 `P "Check the status of your packages:"; 17 23 `Pre "monopam status"; 18 - `P "Pull latest changes from upstream:"; 24 + `P "Pull latest changes from upstream sources:"; 19 25 `Pre "monopam pull"; 20 - `P "Push your changes to upstream:"; 26 + `P "Push your changes to your configured remotes:"; 21 27 `Pre "monopam push"; 22 28 `S "CORE WORKFLOW"; 23 29 `P "Commands match the git mental model:"; 24 - `I ("$(b,monopam add)", "Add a package (subtree) from a git URL"); 30 + `I ("$(b,monopam add)", "Add a package (subtree) from a git URL or name"); 25 31 `I ("$(b,monopam remove)", "Remove a package from the project"); 26 32 `I ("$(b,monopam pull)", "Fetch and merge upstream changes into mono/"); 27 - `I ("$(b,monopam push)", "Push your mono/ changes to upstream remotes"); 33 + `I 34 + ( "$(b,monopam push)", 35 + "Push your mono/ changes to each subtree's configured remote" ); 28 36 `I ("$(b,monopam fetch)", "Fetch upstream changes without merging"); 29 37 `I ("$(b,monopam status)", "Show what's out of sync"); 30 - `I ("$(b,monopam diff)", "Show diff between mono/ and upstream"); 38 + `I ("$(b,monopam diff)", "Show diff between mono/ and the remote"); 31 39 `I ("$(b,monopam publish)", "Publish packages to opam-repo"); 32 40 `S "TYPICAL SESSION"; 33 41 `Pre ··· 39 47 dune build && dune test\n\n\ 40 48 # Commit\n\ 41 49 git add -A && git commit -m \"Add feature\"\n\n\ 42 - # Push to upstream\n\ 50 + # Push to your remotes\n\ 43 51 monopam push"; 44 52 `S "VERSE COLLABORATION"; 45 53 `P "Collaborate with other developers via the verse system:";

+16 -7

lib/config.ml

··· 5 5 6 6 (** {1 Error Helpers} *) 7 7 8 - let err_invalid msg = Error (Fmt.str "Invalid config: %s" msg) 9 - let err_load e = Error (Fmt.str "Error loading config: %s" e) 10 - let err_not_found path = Error (Fmt.str "Config file not found: %s" path) 11 8 let app_name = "monopam" 12 9 13 10 (** {1 Package Overrides} *) ··· 247 244 248 245 (** {1 Loading and Saving} *) 249 246 247 + type load_error = 248 + | Not_found of Fpath.t 249 + | Invalid of { path : Fpath.t; msg : string } 250 + | Io_error of { path : Fpath.t; msg : string } 251 + 252 + let pp_load_error ppf = function 253 + | Not_found path -> Fmt.pf ppf "Config file not found: %a" Fpath.pp path 254 + | Invalid { path; msg } -> 255 + Fmt.pf ppf "Invalid config at %a: %s" Fpath.pp path msg 256 + | Io_error { path; msg } -> 257 + Fmt.pf ppf "Error reading config at %a: %s" Fpath.pp path msg 258 + 250 259 let load ~fs () = 251 260 let path = file () in 252 261 let path_str = Fpath.to_string path in ··· 254 263 match Eio.Path.kind ~follow:true eio_path with 255 264 | `Regular_file -> ( 256 265 try Ok (Tomlt_eio.decode_path_exn codec ~fs path_str) with 257 - | Failure msg -> err_invalid msg 258 - | exn -> err_load (Printexc.to_string exn)) 259 - | _ -> err_not_found path_str 260 - | exception _ -> err_not_found path_str 266 + | Failure msg -> Error (Invalid { path; msg }) 267 + | exn -> Error (Io_error { path; msg = Printexc.to_string exn })) 268 + | _ -> Error (Not_found path) 269 + | exception _ -> Error (Not_found path) 261 270 262 271 let save ~fs t = 263 272 let dir = dir () in

+14 -1

lib/config.mli

··· 157 157 158 158 (** {1 Loading and Saving} *) 159 159 160 - val load : fs:_ Eio.Path.t -> unit -> (t, string) result 160 + (** Errors returned by [load]. Distinct so callers can produce tailored recovery 161 + hints — "run monopam init" only makes sense for [Not_found], not for 162 + [Invalid] or [Io_error]. *) 163 + type load_error = 164 + | Not_found of Fpath.t (** The config file does not exist. *) 165 + | Invalid of { path : Fpath.t; msg : string } 166 + (** The file exists but is not valid TOML / schema. *) 167 + | Io_error of { path : Fpath.t; msg : string } 168 + (** Read failure (permissions, broken symlink, ...). *) 169 + 170 + val pp_load_error : load_error Fmt.t 171 + (** [pp_load_error] formats a [load_error] for display. *) 172 + 173 + val load : fs:_ Eio.Path.t -> unit -> (t, load_error) result 161 174 (** [load ~fs ()] loads the configuration from the XDG config file. 162 175 163 176 @param fs Eio filesystem. *)

+40 -2

lib/ctx.ml

··· 17 17 | Monorepo_dirty 18 18 | Package_not_found of string 19 19 | Claude_error of string 20 + | Other of { msg : string; hint : string option } 21 + 22 + let err ?hint msg = Other { msg; hint } 20 23 21 24 let pp_error ppf = function 22 25 | Config_error msg -> Fmt.pf ppf "Configuration error: %s" msg ··· 29 32 | Monorepo_dirty -> Fmt.pf ppf "Monorepo has uncommitted changes" 30 33 | Package_not_found name -> Fmt.pf ppf "Package not found: %s" name 31 34 | Claude_error msg -> Fmt.pf ppf "Claude error: %s" msg 35 + | Other { msg; hint = _ } -> Fmt.pf ppf "%s" msg 32 36 33 37 let error_hint = function 34 38 | Config_error _ -> ··· 43 47 | Git_error (Git_cli.Dirty_worktree _) -> 44 48 Some "Commit or stash your changes first: cd <repo> && git status" 45 49 | Git_error (Git_cli.Not_a_repo _) -> 46 - Some "Run 'monopam sync' to clone missing repositories." 50 + Some "Run 'monopam pull' to clone missing repositories." 47 51 | Git_error (Git_cli.Subtree_prefix_missing _) -> 48 - Some "Run 'monopam sync' to set up the subtree." 52 + Some "Run 'monopam pull' to set up the subtree." 49 53 | Git_error (Git_cli.Remote_not_found _) -> 50 54 Some "Check that the remote is configured: git remote -v" 51 55 | Git_error (Git_cli.Branch_not_found _) -> ··· 76 80 Some "The Claude API may have returned an unexpected response. Try again." 77 81 | Claude_error _ -> 78 82 Some "Check ANTHROPIC_API_KEY is set. See: https://console.anthropic.com/" 83 + | Other { hint; _ } -> hint 79 84 80 85 let pp_error_with_hint ppf e = 81 86 pp_error ppf e; 82 87 match error_hint e with 83 88 | Some hint -> Fmt.pf ppf "@.@[<v 2>Hint: %s@]" hint 84 89 | None -> () 90 + 91 + (** Map each error category to a shell exit code. See [ctx.mli] for the 92 + contract. Kept as a flat match so new variants force a compile error if 93 + someone extends [error] without thinking about exit codes. *) 94 + let exit_code = function 95 + | Config_error _ -> 2 96 + | Repo_error _ -> 2 97 + | Dirty_state _ -> 2 98 + | Monorepo_dirty -> 2 99 + | Package_not_found _ -> 2 100 + | Claude_error _ -> 5 101 + | Other _ -> 2 102 + | Git_error g -> ( 103 + match g with 104 + | Git_cli.Not_a_repo _ -> 2 105 + | Git_cli.Dirty_worktree _ -> 2 106 + | Git_cli.Remote_not_found _ -> 2 107 + | Git_cli.Branch_not_found _ -> 2 108 + | Git_cli.Subtree_prefix_exists _ -> 2 109 + | Git_cli.Subtree_prefix_missing _ -> 2 110 + | Git_cli.Io_error _ -> 3 111 + | Git_cli.Command_failed (_, r) -> 112 + let err = r.Git_cli.stderr in 113 + let has s = Astring.String.is_infix ~affix:s err in 114 + if has "non-fast-forward" || has "[rejected]" || has "fetch first" 115 + then 4 116 + else if 117 + has "Could not resolve host" 118 + || has "unable to access" || has "Connection refused" 119 + || has "Network is unreachable" 120 + || has "Could not read from remote" 121 + then 3 122 + else 2) 85 123 86 124 (** {1 Filesystem Utilities} *) 87 125

+25

lib/ctx.mli

··· 13 13 | Monorepo_dirty 14 14 | Package_not_found of string 15 15 | Claude_error of string 16 + | Other of { msg : string; hint : string option } 17 + (** Catch-all for one-off errors from add / deps / init / publish that 18 + don't warrant their own variant, but still want a proper hint. *) 16 19 17 20 val pp_error : error Fmt.t 18 21 (** [pp_error] pretty-prints an error. *) ··· 22 25 23 26 val pp_error_with_hint : Format.formatter -> error -> unit 24 27 (** [pp_error_with_hint] pretty-prints an error with a remediation hint. *) 28 + 29 + val err : ?hint:string -> string -> error 30 + (** [err ?hint msg] builds an [Other] error value. The [hint] is attached 31 + verbatim to [pp_error_with_hint]'s output. *) 32 + 33 + val exit_code : error -> int 34 + (** [exit_code e] maps an error to a shell exit code, so scripts can distinguish 35 + categories of failure: 36 + 37 + - [2] — user error: bad args, missing config, dirty state, unknown package, 38 + subtree not yet set up, opam metadata issue. The fix is on the user's 39 + side: edit a file, run [monopam init], install a package. 40 + - [3] — network or I/O error: fetch/clone failed, host unreachable, 41 + filesystem denied. Retry may help; the remote side or the machine is 42 + temporarily in a bad state. 43 + - [4] — push conflict: non-fast-forward, another monorepo or a direct push 44 + got there first. The user needs to pull, resolve, and push again. 45 + - [5] — external service error: Claude API, etc. Not the user's machine, not 46 + git. 47 + 48 + Success (no error) is [0]. This function never returns [0] or [1]; [1] is 49 + reserved for uncaught exceptions and other unexpected crashes. *) 25 50 26 51 (** {1 Filesystem Utilities} *) 27 52

-1054

lib/doctor.ml

··· 1 - (** Doctor command - Claude-powered workspace health analysis. 2 - 3 - Analyzes workspace state, verse member commits, and provides actionable 4 - recommendations for maintaining your monorepo. *) 5 - 6 - let src = Logs.Src.create "monopam.doctor" ~doc:"Doctor analysis" 7 - 8 - module Log = (val Logs.src_log src : Logs.LOG) 9 - 10 - (** {1 Types} *) 11 - 12 - (** Category of a commit change *) 13 - type change_category = 14 - | Security_fix 15 - | Bug_fix 16 - | Feature 17 - | Refactor 18 - | Documentation 19 - | Test 20 - | Other 21 - 22 - (** Priority level for a change *) 23 - type priority = Critical | High | Medium | Low 24 - 25 - (** Recommended action for a commit *) 26 - type recommendation = Merge_now | Review_first | Skip | Needs_discussion 27 - 28 - (** Risk of conflicts when merging *) 29 - type conflict_risk = None_risk | Low_risk | Medium_risk | High_risk 30 - 31 - type commit_analysis = { 32 - hash : string; 33 - subject : string; 34 - author : string; 35 - date : string; 36 - category : change_category; 37 - priority : priority; 38 - recommendation : recommendation; 39 - conflict_risk : conflict_risk; 40 - commit_summary : string; 41 - } 42 - (** Analysis of a single commit from a verse member *) 43 - 44 - type verse_analysis = { 45 - handle : string; 46 - commits : commit_analysis list; 47 - suggested_action : string option; 48 - } 49 - (** Analysis of commits from a specific verse member for a repo *) 50 - 51 - type repo_sync = { 52 - name : string; 53 - local_sync : [ `In_sync | `Ahead of int | `Behind of int | `Needs_sync ]; 54 - remote_ahead : int; 55 - remote_behind : int; 56 - verse_analyses : verse_analysis list; 57 - } 58 - (** Sync status for a single repository *) 59 - 60 - type report_summary = { 61 - repos_total : int; 62 - repos_need_sync : int; 63 - repos_behind_upstream : int; 64 - verse_divergences : int; 65 - } 66 - (** Summary statistics *) 67 - 68 - type action = { 69 - action_priority : priority; 70 - description : string; 71 - command : string option; 72 - } 73 - (** Actionable recommendation *) 74 - 75 - type report = { 76 - timestamp : string; 77 - workspace : string; 78 - report_summary : report_summary; 79 - repos : repo_sync list; 80 - recommendations : action list; 81 - warnings : string list; 82 - } 83 - (** Full doctor report *) 84 - 85 - (** {1 JSON Encoding} *) 86 - 87 - let change_category_to_string = function 88 - | Security_fix -> "security-fix" 89 - | Bug_fix -> "bug-fix" 90 - | Feature -> "feature" 91 - | Refactor -> "refactor" 92 - | Documentation -> "docs" 93 - | Test -> "test" 94 - | Other -> "other" 95 - 96 - let change_category_of_string = function 97 - | "security-fix" -> Security_fix 98 - | "bug-fix" -> Bug_fix 99 - | "feature" -> Feature 100 - | "refactor" -> Refactor 101 - | "docs" -> Documentation 102 - | "test" -> Test 103 - | _ -> Other 104 - 105 - let priority_to_string = function 106 - | Critical -> "critical" 107 - | High -> "high" 108 - | Medium -> "medium" 109 - | Low -> "low" 110 - 111 - let priority_of_string = function 112 - | "critical" -> Critical 113 - | "high" -> High 114 - | "medium" -> Medium 115 - | _ -> Low 116 - 117 - let recommendation_to_string = function 118 - | Merge_now -> "merge-now" 119 - | Review_first -> "review-first" 120 - | Skip -> "skip" 121 - | Needs_discussion -> "needs-discussion" 122 - 123 - let recommendation_of_string = function 124 - | "merge-now" -> Merge_now 125 - | "review-first" -> Review_first 126 - | "skip" -> Skip 127 - | _ -> Needs_discussion 128 - 129 - let conflict_risk_to_string = function 130 - | None_risk -> "none" 131 - | Low_risk -> "low" 132 - | Medium_risk -> "medium" 133 - | High_risk -> "high" 134 - 135 - let conflict_risk_of_string = function 136 - | "none" -> None_risk 137 - | "low" -> Low_risk 138 - | "medium" -> Medium_risk 139 - | "high" -> High_risk 140 - | _ -> Low_risk 141 - 142 - let commit_analysis_jsont = 143 - let make hash subject author date category priority recommendation 144 - conflict_risk commit_summary = 145 - { 146 - hash; 147 - subject; 148 - author; 149 - date; 150 - category = change_category_of_string category; 151 - priority = priority_of_string priority; 152 - recommendation = recommendation_of_string recommendation; 153 - conflict_risk = conflict_risk_of_string conflict_risk; 154 - commit_summary; 155 - } 156 - in 157 - Jsont.Object.map ~kind:"commit_analysis" make 158 - |> Jsont.Object.mem "hash" Jsont.string ~enc:(fun c -> c.hash) 159 - |> Jsont.Object.mem "subject" Jsont.string ~enc:(fun c -> c.subject) 160 - |> Jsont.Object.mem "author" Jsont.string ~enc:(fun c -> c.author) 161 - |> Jsont.Object.mem "date" Jsont.string ~enc:(fun c -> c.date) 162 - |> Jsont.Object.mem "category" Jsont.string ~enc:(fun c -> 163 - change_category_to_string c.category) 164 - |> Jsont.Object.mem "priority" Jsont.string ~enc:(fun c -> 165 - priority_to_string c.priority) 166 - |> Jsont.Object.mem "recommendation" Jsont.string ~enc:(fun c -> 167 - recommendation_to_string c.recommendation) 168 - |> Jsont.Object.mem "conflict_risk" Jsont.string ~enc:(fun c -> 169 - conflict_risk_to_string c.conflict_risk) 170 - |> Jsont.Object.mem "summary" Jsont.string ~enc:(fun c -> c.commit_summary) 171 - |> Jsont.Object.finish 172 - 173 - let verse_analysis_jsont = 174 - let make handle commits suggested_action = 175 - { handle; commits; suggested_action } 176 - in 177 - Jsont.Object.map ~kind:"verse_analysis" make 178 - |> Jsont.Object.mem "handle" Jsont.string ~enc:(fun v -> v.handle) 179 - |> Jsont.Object.mem "commits" (Jsont.list commit_analysis_jsont) 180 - ~enc:(fun v -> v.commits) 181 - |> Jsont.Object.mem "suggested_action" (Jsont.option Jsont.string) 182 - ~dec_absent:None ~enc:(fun v -> v.suggested_action) 183 - |> Jsont.Object.finish 184 - 185 - let local_sync_to_string = function 186 - | `In_sync -> "in_sync" 187 - | `Ahead n -> Fmt.str "ahead:%d" n 188 - | `Behind n -> Fmt.str "behind:%d" n 189 - | `Needs_sync -> "needs_sync" 190 - 191 - let local_sync_of_string s = 192 - if s = "in_sync" then `In_sync 193 - else if s = "needs_sync" then `Needs_sync 194 - else if String.starts_with ~prefix:"ahead:" s then 195 - `Ahead (int_of_string (String.sub s 6 (String.length s - 6))) 196 - else if String.starts_with ~prefix:"behind:" s then 197 - `Behind (int_of_string (String.sub s 7 (String.length s - 7))) 198 - else `Needs_sync 199 - 200 - let repo_sync_jsont = 201 - let make name local_sync remote_ahead remote_behind verse_analyses = 202 - { 203 - name; 204 - local_sync = local_sync_of_string local_sync; 205 - remote_ahead; 206 - remote_behind; 207 - verse_analyses; 208 - } 209 - in 210 - Jsont.Object.map ~kind:"repo_sync" make 211 - |> Jsont.Object.mem "name" Jsont.string ~enc:(fun r -> r.name) 212 - |> Jsont.Object.mem "local_sync" Jsont.string ~enc:(fun r -> 213 - local_sync_to_string r.local_sync) 214 - |> Jsont.Object.mem "remote_ahead" Jsont.int ~enc:(fun r -> r.remote_ahead) 215 - |> Jsont.Object.mem "remote_behind" Jsont.int ~enc:(fun r -> r.remote_behind) 216 - |> Jsont.Object.mem "verse_analyses" (Jsont.list verse_analysis_jsont) 217 - ~enc:(fun r -> r.verse_analyses) 218 - |> Jsont.Object.finish 219 - 220 - let report_summary_jsont = 221 - let make repos_total repos_need_sync repos_behind_upstream verse_divergences : 222 - report_summary = 223 - { repos_total; repos_need_sync; repos_behind_upstream; verse_divergences } 224 - in 225 - Jsont.Object.map ~kind:"report_summary" make 226 - |> Jsont.Object.mem "repos_total" Jsont.int ~enc:(fun s -> s.repos_total) 227 - |> Jsont.Object.mem "repos_need_sync" Jsont.int ~enc:(fun s -> 228 - s.repos_need_sync) 229 - |> Jsont.Object.mem "repos_behind_upstream" Jsont.int ~enc:(fun s -> 230 - s.repos_behind_upstream) 231 - |> Jsont.Object.mem "verse_divergences" Jsont.int ~enc:(fun s -> 232 - s.verse_divergences) 233 - |> Jsont.Object.finish 234 - 235 - let action_jsont = 236 - let make priority description command = 237 - { action_priority = priority_of_string priority; description; command } 238 - in 239 - Jsont.Object.map ~kind:"action" make 240 - |> Jsont.Object.mem "priority" Jsont.string ~enc:(fun a -> 241 - priority_to_string a.action_priority) 242 - |> Jsont.Object.mem "action" Jsont.string ~enc:(fun a -> a.description) 243 - |> Jsont.Object.mem "command" (Jsont.option Jsont.string) ~dec_absent:None 244 - ~enc:(fun a -> a.command) 245 - |> Jsont.Object.finish 246 - 247 - let report_jsont = 248 - let make timestamp workspace report_summary repos recommendations warnings = 249 - { timestamp; workspace; report_summary; repos; recommendations; warnings } 250 - in 251 - Jsont.Object.map ~kind:"report" make 252 - |> Jsont.Object.mem "timestamp" Jsont.string ~enc:(fun r -> r.timestamp) 253 - |> Jsont.Object.mem "workspace" Jsont.string ~enc:(fun r -> r.workspace) 254 - |> Jsont.Object.mem "summary" report_summary_jsont ~enc:(fun r -> 255 - r.report_summary) 256 - |> Jsont.Object.mem "repos" (Jsont.list repo_sync_jsont) ~enc:(fun r -> 257 - r.repos) 258 - |> Jsont.Object.mem "recommendations" (Jsont.list action_jsont) ~enc:(fun r -> 259 - r.recommendations) 260 - |> Jsont.Object.mem "warnings" (Jsont.list Jsont.string) ~enc:(fun r -> 261 - r.warnings) 262 - |> Jsont.Object.finish 263 - 264 - (** {1 Text Rendering} *) 265 - 266 - let pp_priority ppf = function 267 - | Critical -> Fmt.(styled `Red string) ppf "CRIT" 268 - | High -> Fmt.(styled `Red string) ppf "HIGH" 269 - | Medium -> Fmt.(styled `Yellow string) ppf "MED " 270 - | Low -> Fmt.(styled `Faint string) ppf "LOW " 271 - 272 - let pp_category ppf = function 273 - | Security_fix -> Fmt.(styled `Red string) ppf "security" 274 - | Bug_fix -> Fmt.(styled `Magenta string) ppf "bug-fix" 275 - | Feature -> Fmt.(styled `Green string) ppf "feature" 276 - | Refactor -> Fmt.(styled `Cyan string) ppf "refactor" 277 - | Documentation -> Fmt.(styled `Blue string) ppf "docs" 278 - | Test -> Fmt.(styled `Faint string) ppf "test" 279 - | Other -> Fmt.string ppf "other" 280 - 281 - let pp_recommendation ppf = function 282 - | Merge_now -> Fmt.(styled `Green string) ppf "merge-now" 283 - | Review_first -> Fmt.(styled `Yellow string) ppf "review-first" 284 - | Skip -> Fmt.(styled `Faint string) ppf "skip" 285 - | Needs_discussion -> Fmt.(styled `Cyan string) ppf "discuss" 286 - 287 - let pp_conflict_risk ppf = function 288 - | None_risk -> Fmt.(styled `Green string) ppf "none" 289 - | Low_risk -> Fmt.(styled `Green string) ppf "low" 290 - | Medium_risk -> Fmt.(styled `Yellow string) ppf "medium" 291 - | High_risk -> Fmt.(styled `Red string) ppf "high" 292 - 293 - let pp_commit_analysis ppf c = 294 - Fmt.pf ppf " [%a] %s %s@." pp_priority c.priority c.hash c.subject; 295 - Fmt.pf ppf " Category: %a | Risk: %a | Action: %a@." pp_category 296 - c.category pp_conflict_risk c.conflict_risk pp_recommendation 297 - c.recommendation; 298 - if c.commit_summary <> "" then Fmt.pf ppf " -> %s@." c.commit_summary 299 - 300 - let pp_verse_analysis ppf v = 301 - Fmt.pf ppf "@. Their commits from %s (%d):@.@." v.handle 302 - (List.length v.commits); 303 - List.iter (pp_commit_analysis ppf) v.commits; 304 - match v.suggested_action with 305 - | Some cmd -> Fmt.pf ppf "@. Suggested: %s@." cmd 306 - | None -> () 307 - 308 - let pp_repo_sync ppf r = 309 - let local_str = 310 - match r.local_sync with 311 - | `In_sync -> "=" 312 - | `Ahead n -> Fmt.str "+%d" n 313 - | `Behind n -> Fmt.str "-%d" n 314 - | `Needs_sync -> "sync" 315 - in 316 - Fmt.pf ppf "@.%a (local:%s, remote:+%d/-%d)@." 317 - Fmt.(styled `Bold string) 318 - r.name local_str r.remote_ahead r.remote_behind; 319 - if r.verse_analyses <> [] then 320 - List.iter (pp_verse_analysis ppf) r.verse_analyses 321 - 322 - let pp_action ppf a = 323 - Fmt.pf ppf " [%a] %s@." pp_priority a.action_priority a.description; 324 - match a.command with Some cmd -> Fmt.pf ppf " $ %s@." cmd | None -> () 325 - 326 - let pp_report ppf r = 327 - Fmt.pf ppf "@.=== Monopam Doctor Report ===@."; 328 - Fmt.pf ppf "Generated: %s@." r.timestamp; 329 - Fmt.pf ppf "@.Summary:@."; 330 - Fmt.pf ppf " %d repos tracked@." r.report_summary.repos_total; 331 - Fmt.pf ppf " %d need local sync@." r.report_summary.repos_need_sync; 332 - Fmt.pf ppf " %d behind upstream@." r.report_summary.repos_behind_upstream; 333 - Fmt.pf ppf " %d verse divergences@." r.report_summary.verse_divergences; 334 - 335 - (* Only show repos with issues *) 336 - let repos_with_issues = 337 - List.filter 338 - (fun r -> 339 - r.local_sync <> `In_sync || r.remote_behind > 0 340 - || r.verse_analyses <> []) 341 - r.repos 342 - in 343 - if repos_with_issues <> [] then begin 344 - Fmt.pf ppf "@.---@."; 345 - List.iter (pp_repo_sync ppf) repos_with_issues 346 - end; 347 - 348 - if r.recommendations <> [] then begin 349 - Fmt.pf ppf "@.---@."; 350 - Fmt.pf ppf "@.Recommendations:@."; 351 - List.iter (pp_action ppf) r.recommendations 352 - end; 353 - 354 - if r.warnings <> [] then begin 355 - Fmt.pf ppf "@.Warnings:@."; 356 - List.iter (fun w -> Fmt.pf ppf " * %s@." w) r.warnings 357 - end 358 - 359 - (** {1 Claude Analysis} *) 360 - 361 - type remote_status = { 362 - remote_name : string; 363 - url : string; 364 - behind : int; (** Commits remote has that we don't *) 365 - incoming_commits : Git.Repository.log_entry list; 366 - (** Commits from remote we don't have *) 367 - } 368 - (** Information about a single remote's status *) 369 - 370 - (** Analyze a single remote for a checkout *) 371 - let analyze_remote ~sw ~fs ~checkout_dir ~remote_name = 372 - let repo = Git.Repository.open_repo ~sw ~fs checkout_dir in 373 - let url = 374 - Git.Repository.remote_url repo remote_name 375 - |> Option.value ~default:"(unknown)" 376 - in 377 - (* Try to get ahead/behind for this remote *) 378 - let behind = 379 - match Git.Repository.ahead_behind repo ~remote:remote_name () with 380 - | Some ab -> ab.behind 381 - | None -> 0 382 - in 383 - (* Get commits from remote that we don't have *) 384 - let incoming_commits = 385 - if behind > 0 then 386 - let tip = Fmt.str "%s/main" remote_name in 387 - match 388 - Git.Repository.log_range_refs repo ~base:"HEAD" ~tip ~max_count:20 () 389 - with 390 - | Ok commits -> commits 391 - | Error _ -> ( 392 - (* Try with master branch *) 393 - match 394 - Git.Repository.log_range_refs repo ~base:"HEAD" 395 - ~tip:(Fmt.str "%s/master" remote_name) 396 - ~max_count:20 () 397 - with 398 - | Ok commits -> commits 399 - | Error _ -> []) 400 - else [] 401 - in 402 - { remote_name; url; behind; incoming_commits } 403 - 404 - (** Analyze all remotes for a checkout *) 405 - let analyze_checkout_remotes ~sw ~fs ~checkout_dir = 406 - let repo = Git.Repository.open_repo ~sw ~fs checkout_dir in 407 - let remotes = Git.Repository.list_remotes repo in 408 - List.map 409 - (fun remote_name -> analyze_remote ~sw ~fs ~checkout_dir ~remote_name) 410 - remotes 411 - 412 - (** Strip ANSI escape codes from a string *) 413 - let strip_ansi s = 414 - let len = String.length s in 415 - let buf = Buffer.create len in 416 - let rec skip_escape j = 417 - if j >= len || s.[j] = 'm' then j + 1 else skip_escape (j + 1) 418 - in 419 - let rec loop i = 420 - if i >= len then Buffer.contents buf 421 - else if s.[i] = '\027' && i + 1 < len && s.[i + 1] = '[' then 422 - loop (skip_escape (i + 2)) 423 - else begin 424 - Buffer.add_char buf s.[i]; 425 - loop (i + 1) 426 - end 427 - in 428 - loop 0 429 - 430 - (** Build status summary for prompt - includes formatted monopam status output 431 - *) 432 - let build_status_summary statuses = 433 - let buf = Buffer.create 4096 in 434 - Buffer.add_string buf "## Current Monorepo Status\n\n"; 435 - Buffer.add_string buf "Output of `monopam status`:\n```\n"; 436 - (* Capture formatted pp_summary output (strip ANSI codes for prompt) *) 437 - let fmt_output = Fmt.str "%a" (Status.pp_summary ?sources:None) statuses in 438 - Buffer.add_string buf (strip_ansi fmt_output); 439 - Buffer.add_string buf "```\n\n"; 440 - Buffer.add_string buf "Detailed status per repository:\n"; 441 - List.iter 442 - (fun (status : Status.t) -> 443 - let name = Package.repo_name status.package in 444 - let local_str = 445 - match status.subtree_sync with 446 - | Status.In_sync -> "local:=" 447 - | Status.Subtree_behind n -> Fmt.str "local:-%d" n 448 - | Status.Subtree_ahead n -> Fmt.str "local:+%d" n 449 - | Status.Trees_differ -> "local:sync" 450 - | Status.Unknown -> "local:?" 451 - in 452 - let remote_str = 453 - match status.checkout with 454 - | Status.Clean ab -> 455 - if ab.ahead > 0 && ab.behind > 0 then 456 - Fmt.str "remote:+%d/-%d" ab.ahead ab.behind 457 - else if ab.ahead > 0 then Fmt.str "remote:+%d" ab.ahead 458 - else if ab.behind > 0 then Fmt.str "remote:-%d" ab.behind 459 - else "remote:=" 460 - | Status.No_upstream -> "remote:new" 461 - | Status.Dirty -> "remote:dirty" 462 - | Status.Missing -> "remote:missing" 463 - | Status.Not_a_repo -> "remote:not-repo" 464 - in 465 - Buffer.add_string buf (Fmt.str "- %s: %s %s\n" name local_str remote_str)) 466 - statuses; 467 - Buffer.contents buf 468 - 469 - let format_commit buf (c : Git.Repository.log_entry) = 470 - let short_hash = String.sub c.hash 0 (min 7 (String.length c.hash)) in 471 - Buffer.add_string buf 472 - (Fmt.str " - %s %s (%s)\n" short_hash c.subject c.author) 473 - 474 - let format_remote_commits buf r = 475 - if r.behind > 0 then begin 476 - Buffer.add_string buf 477 - (Fmt.str "**%s** (%s) - %d commits behind:\n" r.remote_name r.url r.behind); 478 - List.iter (format_commit buf) r.incoming_commits; 479 - Buffer.add_string buf "\n" 480 - end 481 - 482 - let format_repo_incoming buf repo_name remotes = 483 - let has_incoming = List.exists (fun r -> r.behind > 0) remotes in 484 - if has_incoming then begin 485 - Buffer.add_string buf (Fmt.str "### %s\n\n" repo_name); 486 - List.iter (format_remote_commits buf) remotes 487 - end 488 - 489 - (** Build incoming commits summary for prompt *) 490 - let build_incoming_summary remotes_by_repo = 491 - let buf = Buffer.create 8192 in 492 - Buffer.add_string buf "\n## Incoming Commits from Remotes\n\n"; 493 - List.iter 494 - (fun (repo_name, remotes) -> format_repo_incoming buf repo_name remotes) 495 - remotes_by_repo; 496 - Buffer.contents buf 497 - 498 - (** Prompt instructions for doctor analysis *) 499 - let instructions = 500 - {| 501 - ## Instructions 502 - 503 - Analyze the workspace state and incoming commits. For each repository with incoming commits, 504 - categorize what the changes represent and provide recommendations. 505 - 506 - The status output above shows the current state after syncing. Use this information directly. 507 - 508 - Respond with JSON containing: 509 - - repos: array of repo analyses, each with: 510 - - name: repository name 511 - - verse_analyses: array of analyses per remote with incoming commits: 512 - - handle: remote name 513 - - commits: array of commit analyses: 514 - - hash: short hash 515 - - subject: commit subject 516 - - author: author name 517 - - date: commit date 518 - - category: security-fix, bug-fix, feature, refactor, docs, test, other 519 - - priority: critical, high, medium, low 520 - - recommendation: merge-now, review-first, skip, needs-discussion 521 - - conflict_risk: none, low, medium, high 522 - - summary: one-line description (max 80 chars) 523 - - suggested_action: optional command to handle these commits 524 - - recommendations: array of prioritized actions: 525 - - priority: critical, high, medium, low 526 - - action: description of what to do 527 - - command: optional command to run 528 - - warnings: array of warning strings for any issues detected 529 - |} 530 - 531 - (** Build doctor analysis prompt *) 532 - let build_doctor_prompt ~status_summary ~incoming_summary = 533 - let buf = Buffer.create 16384 in 534 - Buffer.add_string buf 535 - {|You are analyzing a monorepo workspace to provide actionable recommendations. 536 - 537 - IMPORTANT: The workspace has already been synced and the status output is provided below. 538 - You do NOT need to run `monopam status` or `monopam sync` - this has already been done. 539 - Use the status information provided to inform your analysis. 540 - 541 - |}; 542 - Buffer.add_string buf status_summary; 543 - Buffer.add_string buf incoming_summary; 544 - Buffer.add_string buf instructions; 545 - Buffer.contents buf 546 - 547 - (** JSON schema helpers *) 548 - let string_type = 549 - let open Jsont in 550 - Object ([ (("type", Meta.none), String ("string", Meta.none)) ], Meta.none) 551 - 552 - let array_of items = 553 - let open Jsont in 554 - Object 555 - ( [ 556 - (("type", Meta.none), String ("array", Meta.none)); 557 - (("items", Meta.none), items); 558 - ], 559 - Meta.none ) 560 - 561 - let object_with_props props = 562 - let open Jsont in 563 - Object 564 - ( [ 565 - (("type", Meta.none), String ("object", Meta.none)); 566 - (("properties", Meta.none), Object (props, Meta.none)); 567 - ], 568 - Meta.none ) 569 - 570 - let prop name schema = 571 - let open Jsont in 572 - ((name, Meta.none), schema) 573 - 574 - let commit_schema () = 575 - object_with_props 576 - [ 577 - prop "hash" string_type; 578 - prop "subject" string_type; 579 - prop "author" string_type; 580 - prop "date" string_type; 581 - prop "category" string_type; 582 - prop "priority" string_type; 583 - prop "recommendation" string_type; 584 - prop "conflict_risk" string_type; 585 - prop "summary" string_type; 586 - ] 587 - 588 - let verse_schema () = 589 - object_with_props 590 - [ 591 - prop "handle" string_type; 592 - prop "commits" (array_of (commit_schema ())); 593 - prop "suggested_action" string_type; 594 - ] 595 - 596 - let repo_schema () = 597 - object_with_props 598 - [ 599 - prop "name" string_type; 600 - prop "verse_analyses" (array_of (verse_schema ())); 601 - ] 602 - 603 - let action_schema () = 604 - object_with_props 605 - [ 606 - prop "priority" string_type; 607 - prop "action" string_type; 608 - prop "command" string_type; 609 - ] 610 - 611 - (** JSON schema for doctor output *) 612 - let output_schema () = 613 - let open Jsont in 614 - Object 615 - ( [ 616 - (("type", Meta.none), String ("object", Meta.none)); 617 - ( ("properties", Meta.none), 618 - Object 619 - ( [ 620 - prop "repos" (array_of (repo_schema ())); 621 - prop "recommendations" (array_of (action_schema ())); 622 - prop "warnings" (array_of string_type); 623 - ], 624 - Meta.none ) ); 625 - ( ("required", Meta.none), 626 - Array 627 - ( [ 628 - String ("repos", Meta.none); 629 - String ("recommendations", Meta.none); 630 - String ("warnings", Meta.none); 631 - ], 632 - Meta.none ) ); 633 - ], 634 - Meta.none ) 635 - 636 - (** Log tool use for Claude handler *) 637 - let log_tool_use name input = 638 - let get key = 639 - Claude.Tool_input.string input key |> Option.value ~default:"" 640 - in 641 - match name with 642 - | "Bash" -> 643 - let cmd = get "command" in 644 - let short = 645 - if String.length cmd > 60 then String.sub cmd 0 57 ^ "..." else cmd 646 - in 647 - Log.app (fun m -> m " [Bash] %s" short) 648 - | "Read" -> Log.app (fun m -> m " [Read] %s" (get "file_path")) 649 - | "Grep" -> Log.app (fun m -> m " [Grep] %s" (get "pattern")) 650 - | "Glob" -> Log.app (fun m -> m " [Glob] %s" (get "pattern")) 651 - | _ -> Log.app (fun m -> m " [%s]" name) 652 - 653 - (** Create Claude handler for doctor analysis *) 654 - let handler result = 655 - object 656 - inherit Claude.Handler.default 657 - 658 - method! on_text t = 659 - let content = Claude.Response.Text.content t in 660 - if String.length content > 0 then 661 - Log.app (fun m -> m "Claude: %s" content) 662 - 663 - method! on_tool_use t = 664 - log_tool_use 665 - (Claude.Response.Tool_use.name t) 666 - (Claude.Response.Tool_use.input t) 667 - 668 - method! on_complete c = 669 - match Claude.Response.Complete.structured_output c with 670 - | Some json -> result := Some json 671 - | None -> Log.warn (fun m -> m "No structured output from Claude") 672 - 673 - method! on_error e = 674 - Log.warn (fun m -> m "Claude error: %s" (Claude.Response.Error.message e)) 675 - end 676 - 677 - (** Analyze all incoming commits using Claude *) 678 - let analyze_with_claude ~sw ~process_mgr ~clock ~status_summary 679 - ~incoming_summary = 680 - let prompt = build_doctor_prompt ~status_summary ~incoming_summary in 681 - let output_format = 682 - Claude.Proto.Structured_output.of_json_schema (output_schema ()) 683 - in 684 - let options = 685 - Claude.Options.default |> Claude.Options.with_output_format output_format 686 - in 687 - let client = Claude.Client.v ~sw ~process_mgr ~clock ~options () in 688 - Claude.Client.query client prompt; 689 - let result = ref None in 690 - Claude.Client.run client ~handler:(handler result); 691 - !result 692 - 693 - (** {2 JSON Parsing Helpers} *) 694 - 695 - (** Find a member by key in a Jsont object. *) 696 - let json_find_member key obj = 697 - List.find_map (fun ((k, _meta), v) -> if k = key then Some v else None) obj 698 - 699 - (** Get optional string from JSON object. *) 700 - let json_get_string_opt obj key = 701 - match json_find_member key obj with 702 - | Some (Jsont.String (s, _)) -> Some s 703 - | _ -> None 704 - 705 - (** Get string from JSON object with default. *) 706 - let json_get_string obj key default = 707 - Option.value ~default (json_get_string_opt obj key) 708 - 709 - (** Get array from JSON object. *) 710 - let json_get_array obj key = 711 - match json_find_member key obj with 712 - | Some (Jsont.Array (arr, _)) -> arr 713 - | _ -> [] 714 - 715 - (** Parse a commit from JSON. *) 716 - let parse_commit_json c_json = 717 - match c_json with 718 - | Jsont.Object (c_obj, _) -> 719 - Some 720 - { 721 - hash = json_get_string c_obj "hash" ""; 722 - subject = json_get_string c_obj "subject" ""; 723 - author = json_get_string c_obj "author" ""; 724 - date = json_get_string c_obj "date" ""; 725 - category = 726 - change_category_of_string (json_get_string c_obj "category" "other"); 727 - priority = priority_of_string (json_get_string c_obj "priority" "low"); 728 - recommendation = 729 - recommendation_of_string 730 - (json_get_string c_obj "recommendation" "review-first"); 731 - conflict_risk = 732 - conflict_risk_of_string 733 - (json_get_string c_obj "conflict_risk" "low"); 734 - commit_summary = json_get_string c_obj "summary" ""; 735 - } 736 - | _ -> None 737 - 738 - (** Parse a verse analysis from JSON. *) 739 - let parse_verse_analysis_json va_json = 740 - match va_json with 741 - | Jsont.Object (va_obj, _) -> 742 - let handle = json_get_string va_obj "handle" "" in 743 - let commits = 744 - List.filter_map parse_commit_json (json_get_array va_obj "commits") 745 - in 746 - let suggested_action = json_get_string_opt va_obj "suggested_action" in 747 - Some { handle; commits; suggested_action } 748 - | _ -> None 749 - 750 - (** Parse a repo from JSON. *) 751 - let parse_repo_json repo_json = 752 - match repo_json with 753 - | Jsont.Object (repo_obj, _) -> 754 - let name = json_get_string repo_obj "name" "" in 755 - let verse_analyses = 756 - List.filter_map parse_verse_analysis_json 757 - (json_get_array repo_obj "verse_analyses") 758 - in 759 - if verse_analyses <> [] then 760 - Some 761 - { 762 - name; 763 - local_sync = `In_sync; 764 - remote_ahead = 0; 765 - remote_behind = 0; 766 - verse_analyses; 767 - } 768 - else None 769 - | _ -> None 770 - 771 - (** Parse a recommendation from JSON. *) 772 - let parse_recommendation_json rec_json = 773 - match rec_json with 774 - | Jsont.Object (rec_obj, _) -> 775 - let action_priority = 776 - priority_of_string (json_get_string rec_obj "priority" "low") 777 - in 778 - let description = json_get_string rec_obj "action" "" in 779 - let command = json_get_string_opt rec_obj "command" in 780 - Some { action_priority; description; command } 781 - | _ -> None 782 - 783 - (** Parse a warning from JSON. *) 784 - let parse_warning_json w_json = 785 - match w_json with Jsont.String (s, _) -> Some s | _ -> None 786 - 787 - (** Parse Claude's JSON response into our types *) 788 - let parse_claude_response json = 789 - match json with 790 - | Jsont.Object (obj, _) -> 791 - let repos = 792 - List.filter_map parse_repo_json (json_get_array obj "repos") 793 - in 794 - let recommendations = 795 - List.filter_map parse_recommendation_json 796 - (json_get_array obj "recommendations") 797 - in 798 - let warnings = 799 - List.filter_map parse_warning_json (json_get_array obj "warnings") 800 - in 801 - (repos, recommendations, warnings) 802 - | _ -> ([], [], []) 803 - 804 - (** {1 Main Analysis} *) 805 - 806 - (** Check repos for dirty state, returning warnings *) 807 - let check_dirty_repos ~sw ~fs ~config = 808 - let warnings = ref [] in 809 - let opam_repo = Config.Paths.opam_repo config in 810 - if Git.Repository.is_repo ~fs opam_repo then begin 811 - let repo = Git.Repository.open_repo ~sw ~fs opam_repo in 812 - if Git.Repository.is_dirty repo then 813 - warnings := "opam-repo has uncommitted changes" :: !warnings 814 - end; 815 - let monorepo = Config.Paths.monorepo config in 816 - if Git.Repository.is_repo ~fs monorepo then begin 817 - let repo = Git.Repository.open_repo ~sw ~fs monorepo in 818 - if Git.Repository.is_dirty repo then 819 - warnings := "monorepo has uncommitted changes" :: !warnings 820 - end; 821 - !warnings 822 - 823 - (** Build base repo_sync list from statuses *) 824 - let build_base_repos statuses = 825 - List.map 826 - (fun (status : Status.t) -> 827 - let name = Package.repo_name status.package in 828 - let local_sync = 829 - match status.subtree_sync with 830 - | Status.In_sync -> `In_sync 831 - | Status.Subtree_behind n -> `Behind n 832 - | Status.Subtree_ahead n -> `Ahead n 833 - | Status.Trees_differ | Status.Unknown -> `Needs_sync 834 - in 835 - let remote_ahead, remote_behind = 836 - match status.checkout with 837 - | Status.Clean ab -> (ab.ahead, ab.behind) 838 - | _ -> (0, 0) 839 - in 840 - { name; local_sync; remote_ahead; remote_behind; verse_analyses = [] }) 841 - statuses 842 - 843 - (** Build recommendations list from repos state *) 844 - let build_recommendations ~repos_need_sync ~repos_behind_upstream 845 - claude_recommendations = 846 - let recommendations = ref claude_recommendations in 847 - if 848 - repos_need_sync > 0 849 - && not 850 - (List.exists 851 - (fun r -> 852 - String.starts_with ~prefix:"Run monopam sync" r.description) 853 - !recommendations) 854 - then 855 - recommendations := 856 - { 857 - action_priority = Medium; 858 - description = 859 - Fmt.str "Run monopam sync to resolve %d local sync issues" 860 - repos_need_sync; 861 - command = Some "monopam sync"; 862 - } 863 - :: !recommendations; 864 - if 865 - repos_behind_upstream > 0 866 - && not 867 - (List.exists 868 - (fun r -> String.starts_with ~prefix:"Pull upstream" r.description) 869 - !recommendations) 870 - then 871 - recommendations := 872 - { 873 - action_priority = Medium; 874 - description = 875 - Fmt.str "Pull upstream changes for %d repos" repos_behind_upstream; 876 - command = Some "monopam sync"; 877 - } 878 - :: !recommendations; 879 - let priority_order = function 880 - | Critical -> 0 881 - | High -> 1 882 - | Medium -> 2 883 - | Low -> 3 884 - in 885 - List.sort 886 - (fun a b -> 887 - compare 888 - (priority_order a.action_priority) 889 - (priority_order b.action_priority)) 890 - !recommendations 891 - 892 - let compute_statuses ~sw ~fs ~config ?package () = 893 - let packages = 894 - match 895 - Opam_repo.scan ~fs:(fs :> _ Eio.Path.t) (Config.Paths.opam_repo config) 896 - with 897 - | Ok pkgs -> pkgs 898 - | Error _ -> [] 899 - in 900 - let statuses = Status.compute_all ~sw ~fs ~config packages in 901 - match package with 902 - | None -> statuses 903 - | Some name -> 904 - List.filter (fun (s : Status.t) -> Package.name s.package = name) statuses 905 - 906 - let collect_remotes_by_repo ~sw ~fs ~config statuses = 907 - let checkouts_root = Config.Paths.checkouts config in 908 - List.filter_map 909 - (fun (status : Status.t) -> 910 - let name = Package.repo_name status.package in 911 - let checkout_dir = Fpath.(checkouts_root / name) in 912 - match status.checkout with 913 - | Status.Missing | Status.Not_a_repo -> None 914 - | _ -> Some (name, analyze_checkout_remotes ~sw ~fs ~checkout_dir)) 915 - statuses 916 - 917 - let merge_claude_repos ~base_repos claude_repos = 918 - List.map 919 - (fun base_repo -> 920 - match List.find_opt (fun cr -> cr.name = base_repo.name) claude_repos with 921 - | Some cr -> { base_repo with verse_analyses = cr.verse_analyses } 922 - | None -> base_repo) 923 - base_repos 924 - 925 - let analyze_incoming ~sw ~proc ~clock ~statuses ~remotes_by_repo ~base_repos 926 - repos_with_incoming = 927 - if repos_with_incoming <> [] then begin 928 - Log.app (fun m -> 929 - m "Found %d repos with incoming changes, analyzing with Claude..." 930 - (List.length repos_with_incoming)); 931 - let status_summary = build_status_summary statuses in 932 - let incoming_summary = build_incoming_summary remotes_by_repo in 933 - match 934 - analyze_with_claude ~sw ~process_mgr:proc ~clock ~status_summary 935 - ~incoming_summary 936 - with 937 - | Some json -> 938 - let claude_repos, recs, warns = parse_claude_response json in 939 - (merge_claude_repos ~base_repos claude_repos, recs, warns) 940 - | None -> 941 - Log.warn (fun m -> m "Claude analysis failed, using basic status"); 942 - (base_repos, [], []) 943 - end 944 - else begin 945 - Log.app (fun m -> m "No incoming changes from remotes"); 946 - (base_repos, [], []) 947 - end 948 - 949 - let build_report_summary repos = 950 - let repos_need_sync = 951 - List.length (List.filter (fun r -> r.local_sync <> `In_sync) repos) 952 - in 953 - let repos_behind_upstream = 954 - List.length (List.filter (fun r -> r.remote_behind > 0) repos) 955 - in 956 - let verse_divergences = 957 - List.fold_left (fun acc r -> acc + List.length r.verse_analyses) 0 repos 958 - in 959 - ( { 960 - repos_total = List.length repos; 961 - repos_need_sync; 962 - repos_behind_upstream; 963 - verse_divergences; 964 - }, 965 - repos_need_sync, 966 - repos_behind_upstream ) 967 - 968 - (** Run the doctor analysis *) 969 - let analyze ~sw ~proc ~fs ~config ~verse_config ~clock ?package 970 - ?(no_sync = false) () = 971 - let _ = no_sync in 972 - let now = Eio.Time.now clock in 973 - let now_ptime = 974 - Ptime.of_float_s now |> Option.value ~default:(Ptime.v (0, 0L)) 975 - in 976 - let timestamp = Ptime.to_rfc3339 now_ptime ~tz_offset_s:0 in 977 - let workspace = Fpath.to_string (Verse_config.root verse_config) in 978 - let statuses = compute_statuses ~sw ~fs ~config ?package () in 979 - let warnings = check_dirty_repos ~sw ~fs ~config in 980 - Log.app (fun m -> 981 - m "Analyzing remotes for %d repositories..." (List.length statuses)); 982 - let remotes_by_repo = collect_remotes_by_repo ~sw ~fs ~config statuses in 983 - let repos_with_incoming = 984 - List.filter 985 - (fun (_name, remotes) -> List.exists (fun r -> r.behind > 0) remotes) 986 - remotes_by_repo 987 - in 988 - let base_repos = build_base_repos statuses in 989 - let repos, claude_recommendations, claude_warnings = 990 - analyze_incoming ~sw ~proc ~clock ~statuses ~remotes_by_repo ~base_repos 991 - repos_with_incoming 992 - in 993 - let report_summary, repos_need_sync, repos_behind_upstream = 994 - build_report_summary repos 995 - in 996 - let recommendations = 997 - build_recommendations ~repos_need_sync ~repos_behind_upstream 998 - claude_recommendations 999 - in 1000 - { 1001 - timestamp; 1002 - workspace; 1003 - report_summary; 1004 - repos; 1005 - recommendations; 1006 - warnings = warnings @ claude_warnings; 1007 - } 1008 - 1009 - (** Encode report to JSON string *) 1010 - let to_json report = 1011 - match 1012 - Jsont_bytesrw.encode_string ~format:Jsont.Indent report_jsont report 1013 - with 1014 - | Ok s -> s 1015 - | Error e -> Fmt.failwith "Failed to encode report: %s" e 1016 - 1017 - (** {1 Health Status} *) 1018 - 1019 - (** Health status for cron-job style exit codes *) 1020 - type health = Healthy | Warning | Critical 1021 - 1022 - let health_to_exit_code = function Healthy -> 0 | Warning -> 1 | Critical -> 2 1023 - 1024 - (** Compute overall health status from a report. 1025 - - Critical: has critical/high priority issues or warnings 1026 - - Warning: has medium priority issues, sync needed, or behind upstream 1027 - - Healthy: no issues found *) 1028 - let compute_health report = 1029 - (* Check for critical/high priority recommendations *) 1030 - let has_critical = 1031 - List.exists 1032 - (fun a -> 1033 - match a.action_priority with Critical | High -> true | _ -> false) 1034 - report.recommendations 1035 - in 1036 - (* Check for warnings *) 1037 - let has_warnings = report.warnings <> [] in 1038 - (* Check for sync issues or upstream drift *) 1039 - let has_sync_issues = 1040 - report.report_summary.repos_need_sync > 0 1041 - || report.report_summary.repos_behind_upstream > 0 1042 - || report.report_summary.verse_divergences > 0 1043 - in 1044 - if has_critical || has_warnings then Critical 1045 - else if has_sync_issues then Warning 1046 - else Healthy 1047 - 1048 - (** Check if the report has any issues worth reporting *) 1049 - let has_issues report = 1050 - report.report_summary.repos_need_sync > 0 1051 - || report.report_summary.repos_behind_upstream > 0 1052 - || report.report_summary.verse_divergences > 0 1053 - || report.warnings <> [] 1054 - || report.recommendations <> []

-196

lib/doctor.mli

··· 1 - (** Doctor command - Claude-powered workspace health analysis. 2 - 3 - Analyzes workspace state, verse member commits, and provides actionable 4 - recommendations for maintaining your monorepo. 5 - 6 - The doctor command uses Claude AI to analyze commits from verse 7 - collaborators, categorizing them by type, priority, and risk level. 8 - 9 - {1 Quick Start} 10 - 11 - Run the doctor analysis: 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 19 - ]} 20 - 21 - Or output as JSON: 22 - {[ 23 - let json = Doctor.to_json report in 24 - print_endline json 25 - ]} *) 26 - 27 - (** {1 Types} *) 28 - 29 - (** Category of a commit change *) 30 - type change_category = 31 - | Security_fix 32 - | Bug_fix 33 - | Feature 34 - | Refactor 35 - | Documentation 36 - | Test 37 - | Other 38 - 39 - (** Priority level for a change *) 40 - type priority = Critical | High | Medium | Low 41 - 42 - (** Recommended action for a commit *) 43 - type recommendation = Merge_now | Review_first | Skip | Needs_discussion 44 - 45 - (** Risk of conflicts when merging *) 46 - type conflict_risk = None_risk | Low_risk | Medium_risk | High_risk 47 - 48 - type commit_analysis = { 49 - hash : string; 50 - subject : string; 51 - author : string; 52 - date : string; 53 - category : change_category; 54 - priority : priority; 55 - recommendation : recommendation; 56 - conflict_risk : conflict_risk; 57 - commit_summary : string; 58 - } 59 - (** Analysis of a single commit from a verse member *) 60 - 61 - type verse_analysis = { 62 - handle : string; 63 - commits : commit_analysis list; 64 - suggested_action : string option; 65 - } 66 - (** Analysis of commits from a specific verse member for a repo *) 67 - 68 - type repo_sync = { 69 - name : string; 70 - local_sync : [ `In_sync | `Ahead of int | `Behind of int | `Needs_sync ]; 71 - remote_ahead : int; 72 - remote_behind : int; 73 - verse_analyses : verse_analysis list; 74 - } 75 - (** Sync status for a single repository *) 76 - 77 - type report_summary = { 78 - repos_total : int; 79 - repos_need_sync : int; 80 - repos_behind_upstream : int; 81 - verse_divergences : int; 82 - } 83 - (** Summary statistics *) 84 - 85 - type action = { 86 - action_priority : priority; 87 - description : string; 88 - command : string option; 89 - } 90 - (** Actionable recommendation *) 91 - 92 - type report = { 93 - timestamp : string; 94 - workspace : string; 95 - report_summary : report_summary; 96 - repos : repo_sync list; 97 - recommendations : action list; 98 - warnings : string list; 99 - } 100 - (** Full doctor report *) 101 - 102 - (** {1 Pretty Printing} *) 103 - 104 - val pp_priority : priority Fmt.t 105 - (** [pp_priority] formats a priority level with colors. *) 106 - 107 - val pp_category : change_category Fmt.t 108 - (** [pp_category] formats a change category with colors. *) 109 - 110 - val pp_recommendation : recommendation Fmt.t 111 - (** [pp_recommendation] formats a recommendation with colors. *) 112 - 113 - val pp_conflict_risk : conflict_risk Fmt.t 114 - (** [pp_conflict_risk] formats a conflict risk level with colors. *) 115 - 116 - val pp_commit_analysis : commit_analysis Fmt.t 117 - (** [pp_commit_analysis] formats a single commit analysis. *) 118 - 119 - val pp_verse_analysis : verse_analysis Fmt.t 120 - (** [pp_verse_analysis] formats verse member analysis. *) 121 - 122 - val pp_repo_sync : repo_sync Fmt.t 123 - (** [pp_repo_sync] formats repository sync status. *) 124 - 125 - val pp_action : action Fmt.t 126 - (** [pp_action] formats an action recommendation. *) 127 - 128 - val pp_report : report Fmt.t 129 - (** [pp_report] formats the full doctor report as human-readable text. *) 130 - 131 - (** {1 JSON Encoding} *) 132 - 133 - val report_jsont : report Jsont.t 134 - (** [report_jsont] is the Jsont codec for the report type. *) 135 - 136 - val to_json : report -> string 137 - (** [to_json report] encodes the report as a JSON string. *) 138 - 139 - (** {1 Analysis} *) 140 - 141 - val analyze : 142 - sw:Eio.Switch.t -> 143 - proc:_ Eio.Process.mgr -> 144 - fs:Eio.Fs.dir_ty Eio.Path.t -> 145 - config:Config.t -> 146 - verse_config:Verse_config.t -> 147 - clock:float Eio.Time.clock_ty Eio.Resource.t -> 148 - ?package:string -> 149 - ?no_sync:bool -> 150 - unit -> 151 - report 152 - (** [analyze ~proc ~fs ~config ~verse_config ~clock ?package ?no_sync ()] runs 153 - the doctor analysis and returns a report. 154 - 155 - By default, runs [monopam sync] first to ensure the workspace is up-to-date 156 - before analysis. Use [~no_sync:true] to skip the initial sync. 157 - 158 - Performs the following analysis: 1. Runs sync to update workspace (unless 159 - [~no_sync:true]) 2. Computes status for all packages (or the specified 160 - package) 3. Checks for dirty state in opam-repo and monorepo 4. Analyzes 161 - fork relationships with verse members 5. Uses Claude AI to categorize and 162 - prioritize verse commits 6. Generates actionable recommendations 163 - 164 - The status output from [monopam status] is provided directly to Claude in 165 - the prompt, so Claude doesn't need to run it separately. 166 - 167 - @param proc Eio process manager. 168 - @param fs Eio filesystem. 169 - @param config Monopam configuration. 170 - @param verse_config Verse/opamverse configuration. 171 - @param clock Eio clock for time operations. 172 - @param package Optional specific package to analyze. 173 - @param no_sync If true, skip the initial sync (default: false). *) 174 - 175 - (** {1 Health Status (for cron jobs)} *) 176 - 177 - (** Health status for exit code determination *) 178 - type health = Healthy | Warning | Critical 179 - 180 - val health_to_exit_code : health -> int 181 - (** [health_to_exit_code h] returns the exit code for the given health status. 182 - 183 - - [Healthy] = 0 184 - - [Warning] = 1 185 - - [Critical] = 2. *) 186 - 187 - val compute_health : report -> health 188 - (** [compute_health report] computes the overall health status from a report. 189 - 190 - - [Critical]: has critical/high priority issues or warnings. 191 - - [Warning]: has medium priority issues, sync needed, or behind upstream. 192 - - [Healthy]: no issues found. *) 193 - 194 - val has_issues : report -> bool 195 - (** [has_issues report] returns true if the report has any issues worth 196 - reporting (sync needed, behind upstream, warnings, or recommendations). *)

+87 -3

lib/import.ml

··· 56 56 "git+https" ^ String.sub url 4 (String.length url - 4) 57 57 else "git+" ^ url 58 58 59 + (** Does [s] look like a URL we can hand to git, or a filesystem path? Used to 60 + disambiguate [monopam add crowbar] (package name) from 61 + [monopam add https://...] (URL) or [monopam add ./repo] (local path). *) 62 + let looks_like_url s = 63 + String.contains s '/' || String.contains s ':' 64 + || String.starts_with ~prefix:"git@" s 65 + || String.starts_with ~prefix:"git+" s 66 + || String.starts_with ~prefix:"http" s 67 + || String.ends_with ~suffix:".git" s 68 + 69 + (** Look [name] up in a local opam-repo overlay and return its dev-repo URL. 70 + Returns [None] if the package is absent or has no dev-repo. *) 71 + let resolve_from_local_repo ~fs ~opam_repo name = 72 + match Opam_repo.scan ~fs opam_repo with 73 + | Error _ -> None 74 + | Ok pkgs -> ( 75 + match List.find_opt (fun p -> Package.name p = name) pkgs with 76 + | None -> None 77 + | Some pkg -> 78 + let uri = Package.dev_repo pkg in 79 + Some (Uri.to_string uri)) 80 + 81 + (** Strip a trailing branch/ref from a dev-repo URL returned by [opam show]. 82 + Opam formats them as [git+https://...#branch]. *) 83 + let strip_opam_ref url = 84 + match String.index_opt url '#' with 85 + | Some i -> String.sub url 0 i 86 + | None -> url 87 + 88 + (** Shell out to [opam show] to resolve a package name against the user's opam 89 + switch. Returns [None] if opam is not installed or the package is unknown. 90 + *) 91 + let resolve_from_opam_cli ~proc name = 92 + let buf = Buffer.create 256 in 93 + let err = Buffer.create 64 in 94 + try 95 + Eio.Process.run proc ~stdout:(Eio.Flow.buffer_sink buf) 96 + ~stderr:(Eio.Flow.buffer_sink err) 97 + [ "opam"; "show"; name; "--field"; "dev-repo" ]; 98 + let out = Buffer.contents buf |> String.trim in 99 + (* opam prints the URL wrapped in quotes. Strip them. *) 100 + let len = String.length out in 101 + let unquoted = 102 + if len >= 2 && out.[0] = '"' && out.[len - 1] = '"' then 103 + String.sub out 1 (len - 2) 104 + else out 105 + in 106 + let cleaned = strip_opam_ref unquoted in 107 + if cleaned = "" then None else Some cleaned 108 + with Eio.Io _ -> None 109 + 110 + let resolve_name ~proc ~fs ?opam_repo name = 111 + match opam_repo with 112 + | Some path -> ( 113 + match resolve_from_local_repo ~fs ~opam_repo:path name with 114 + | Some url -> Ok url 115 + | None -> ( 116 + match resolve_from_opam_cli ~proc name with 117 + | Some url -> Ok url 118 + | None -> 119 + Error 120 + (Fmt.str 121 + "No dev-repo found for package %S. Tried the local \ 122 + opam-repo overlay and `opam show`. Pass a git URL directly \ 123 + to bypass resolution." 124 + name))) 125 + | None -> ( 126 + match resolve_from_opam_cli ~proc name with 127 + | Some url -> Ok url 128 + | None -> 129 + Error 130 + (Fmt.str 131 + "No dev-repo found for package %S via `opam show`. Pass a git \ 132 + URL directly (e.g. https://github.com/owner/%s.git) if the \ 133 + package is not in your current opam switch." 134 + name name)) 135 + 59 136 (** Strip git+ prefix for git commands *) 60 137 let strip_git_prefix url = 61 138 if String.starts_with ~prefix:"git+" url then ··· 310 387 match Sources_registry.save ~fs sources_path sources with 311 388 | Ok () -> ( 312 389 let git_repo = Git.Repository.open_repo ~sw ~fs target in 313 - match 314 - Git.Repository.add_to_index git_repo [ "sources.toml" ] 315 - with 390 + (* After [Git.Subtree.add] the HEAD commit contains the 391 + newly-added subtree, but the on-disk index is still the 392 + pre-add index (subtree.add writes directly via git 393 + plumbing without touching the index). Using 394 + [add_to_index ["sources.toml"]] would commit a tree 395 + derived from that stale index, dropping the subtree. 396 + [add_all] rebuilds the index from the working tree so 397 + the follow-up commit includes every file present — 398 + subtree files, dune-project, root.opam, sources.toml. *) 399 + match Git.Repository.add_all git_repo with 316 400 | Ok () -> ( 317 401 let msg = 318 402 Fmt.str "Update sources.toml: add %s" result.name

+21

lib/import.mli

··· 24 24 val normalize_url : string -> string 25 25 (** [normalize_url url] ensures the URL has a "git+" prefix. *) 26 26 27 + val looks_like_url : string -> bool 28 + (** [looks_like_url s] returns [true] if [s] is plausibly a git URL or 29 + filesystem path. Used to decide whether to treat an [add] argument as a 30 + direct URL or as an opam package name that needs resolving. *) 31 + 32 + val resolve_name : 33 + proc:_ Eio.Process.mgr -> 34 + fs:Eio.Fs.dir_ty Eio.Path.t -> 35 + ?opam_repo:Fpath.t -> 36 + string -> 37 + (string, string) Stdlib.result 38 + (** [resolve_name ~proc ~fs ?opam_repo name] resolves an opam package name to a 39 + git dev-repo URL. Resolution order: 40 + 41 + - If [opam_repo] is given, look up [name] in the local overlay first. 42 + - Otherwise, shell out to [opam show <name> --field dev-repo] and parse the 43 + result. 44 + 45 + Returns [Ok url] on success or [Error msg] if neither path yielded a usable 46 + URL. *) 47 + 27 48 (** {1 Import Operations} *) 28 49 29 50 val run :

+58 -43

lib/init.ml

··· 13 13 {|# Monorepo Development Guide 14 14 15 15 This is a monorepo managed by `monopam`. Each subdirectory is a subtree 16 - from a separate upstream repository. 16 + from a separate upstream repository. You edit everything in one tree, 17 + build with dune, then `pull` and `push` to move changes in and out. 17 18 18 19 > **Note:** Check `CLAUDE.local.md` (if it exists) for additional local 19 20 > configuration or preferences specific to this workspace. 20 21 21 22 ## Quick Reference 22 23 23 - | Task | Command | 24 - |------|---------| 25 - | Check status | `monopam status` | 26 - | Sync all repos | `monopam sync` | 27 - | Sync and push upstream | `monopam sync --remote` | 28 - | Sync one repo | `monopam sync <repo-name>` | 29 - | Build | `opam exec -- dune build` | 30 - | Test | `opam exec -- dune test` | 24 + | Task | Command | 25 + |------------------------------------|------------------------------| 26 + | Check status | `monopam status` | 27 + | Fetch upstream changes | `monopam pull` | 28 + | Push changes to your remotes | `monopam push` | 29 + | Export to checkouts only (no push) | `monopam push --local` | 30 + | Operate on one package | `monopam <cmd> <name>` | 31 + | Build | `opam exec -- dune build` | 32 + | Test | `opam exec -- dune test` | 31 33 |} 32 34 33 35 let claude_md_workflow = 34 36 {|## Daily Workflow 35 37 36 38 ```bash 37 - # 1. Check what needs syncing 39 + # 1. See what needs attention 38 40 monopam status 39 41 40 - # 2. Sync your monorepo with all upstreams 41 - monopam sync 42 + # 2. Pull latest upstream changes into the monorepo 43 + monopam pull 42 44 43 - # 3. Make your changes, build and test 45 + # 3. Make your changes anywhere in the tree, build and test 44 46 opam exec -- dune build && opam exec -- dune test 45 47 46 - # 4. Commit your changes 48 + # 4. Commit your changes to the monorepo 47 49 git add -A && git commit -m "Description of changes" 48 50 49 - # 5. Sync and push to upstream remotes 50 - monopam sync --remote 51 + # 5. Send them back to the upstream repos 52 + monopam push 51 53 ``` 52 54 55 + `pull` and `push` are the only sync verbs. There is no `sync` command: 56 + pulling first, building, testing, then pushing keeps the two directions 57 + decoupled so you always know what state you're in. 58 + 53 59 ## Understanding Status Output 54 60 55 61 Run `monopam status` to see the sync state: 56 62 57 - - `local:=` - Monorepo and checkout in sync 58 - - `local:+N` - Monorepo is N commits ahead (run `monopam sync`) 59 - - `local:-N` - Checkout is N commits ahead (run `monopam sync`) 60 - - `local:sync` - Trees differ, needs sync (run `monopam sync`) 61 - - `remote:=` - Checkout and upstream in sync 62 - - `remote:+N` - You have N commits to push (run `monopam sync --remote`) 63 - - `remote:-N` - Upstream has N commits to pull (run `monopam sync`) 63 + - `local:=` — Monorepo and checkout in sync 64 + - `local:+N` — Monorepo has N commits not in checkout (run `monopam push --local`) 65 + - `local:-N` — Checkout has N commits not in monorepo (run `monopam pull`) 66 + - `local:sync` — Trees differ; run `monopam pull` then `monopam push` to reconcile 67 + - `remote:=` — Checkout and upstream in sync 68 + - `remote:+N` — You have N commits to push (run `monopam push`) 69 + - `remote:-N` — Upstream has N commits to pull (run `monopam pull`) 64 70 65 71 ## Making Changes 66 72 67 73 1. **Edit code** in any subdirectory as normal 68 74 2. **Build and test**: `opam exec -- dune build && opam exec -- dune test` 69 75 3. **Commit** your changes: `git add -A && git commit` 70 - 4. **Sync**: `monopam sync --remote` to push to upstreams 76 + 4. **Push**: `monopam push` to send them upstream 71 77 72 78 ## Important Notes 73 79 74 - - **Always commit before sync**: `monopam sync` only exports committed changes 80 + - **Always commit before push**: `monopam push` only exports committed changes 75 81 - **Check status first**: Run `monopam status` to see what needs attention 76 82 - **One repo per directory**: Each subdirectory maps to exactly one git remote 77 83 |} ··· 79 85 let claude_md_troubleshooting = 80 86 {|## Troubleshooting 81 87 82 - ### "Dirty packages" Error 83 - Commit your changes first: 88 + ### `local:sync` in status 89 + The monorepo subtree and checkout have diverged trees and monopam can't 90 + pick a direction automatically. Pull first, then push: 91 + 84 92 ```bash 85 - git status && git add -A && git commit -m "Your message" 93 + monopam pull 94 + monopam push 86 95 ``` 87 96 88 - ### "local:sync" in Status 89 - Trees differ but need syncing: 90 - ```bash 91 - monopam sync 92 - ``` 97 + ### Merge conflicts after `monopam pull` 98 + Resolve conflicts in `mono/`, then commit and continue: 93 99 94 - ### Merge Conflicts 95 - Resolve conflicts, commit, then sync: 96 100 ```bash 97 101 git add -A && git commit -m "Resolve merge conflicts" 98 - monopam sync 102 + monopam push # only if you want to publish the resolution 99 103 ``` 100 104 101 - ### Push Fails 102 - Check credentials: 105 + ### Push fails with non-fast-forward 106 + Another monorepo (or a direct commit) got there first. Pull, rebuild, then 107 + retry: 108 + 103 109 ```bash 104 - cd ../src/<repo-name> 105 - git push origin main # For better error messages 110 + monopam pull 111 + opam exec -- dune build && opam exec -- dune test 112 + monopam push 106 113 ``` 107 114 115 + If the upstream history is intentionally diverged (e.g. after `git 116 + filter-repo`), `monopam push --force` overrides. 117 + 118 + ### A checkout is missing 119 + Usually means `src/<repo>` hasn't been cloned yet. `monopam pull` will 120 + clone missing checkouts as part of its normal flow. 121 + 108 122 ## Getting Help 109 123 110 124 ```bash 111 - monopam --help # Main help 112 - monopam sync --help # Sync command help 113 - monopam status --help # Status command help 125 + monopam --help # List of all commands 126 + monopam pull --help # Pull command help 127 + monopam push --help # Push command help 128 + monopam status --help # Status command help 114 129 ``` 115 130 |} 116 131

-1

lib/monopam.ml

··· 16 16 module Verse_registry = Verse_registry 17 17 module Cross_status = Cross_status 18 18 module Forks = Forks 19 - module Doctor = Doctor 20 19 module Feature = Feature 21 20 module Dune_project = Dune_project 22 21 module Opam_transform = Opam_transform

-1

lib/monopam.mli

··· 38 38 module Verse_registry = Verse_registry 39 39 module Cross_status = Cross_status 40 40 module Forks = Forks 41 - module Doctor = Doctor 42 41 module Feature = Feature 43 42 module Dune_project = Dune_project 44 43 module Opam_transform = Opam_transform

+37 -17

lib/push.ml

··· 1 - (** Push operations for exporting monorepo changes to checkouts and upstream. 1 + (** Push operations for exporting monorepo changes to checkouts and remotes. 2 2 3 - Extracts per-package commits and pushes to local checkouts and optionally to 4 - remote upstreams. *) 3 + Extracts per-package commits and pushes to local checkouts under [src/] and 4 + then, unless [--local] was passed, to the git remote configured for each 5 + subtree. Those remotes are always the user's own repositories (origin, not 6 + upstream in the git sense) — push never writes to a canonical repo the user 7 + doesn't own. *) 5 8 6 9 let src = Logs.Src.create "monopam.push" ~doc:"Monopam push operations" 7 10 ··· 275 278 276 279 let to_upstream ~sw ~proc ~fs ~config ~sources ~force ~progress pushed_repos = 277 280 Log.info (fun m -> 278 - m "Pushing %d repos to upstream (parallel)" (List.length pushed_repos)); 281 + m "Pushing %d repos to configured remotes (parallel)" 282 + (List.length pushed_repos)); 279 283 let checkouts_root = Config.Paths.checkouts config in 280 284 Eio.Fiber.List.map ~max_fibers:8 281 285 (fun pkg -> ··· 299 303 | Error (`Msg msg) -> 300 304 Log.warn (fun m -> m "Failed to set push URL: %s" msg)); 301 305 match Git_cli.push_remote ~proc ~fs ~branch ~force checkout_dir with 302 - | Ok () -> Ok name 303 - | Error e -> Error (name, Ctx.Git_error e)) 306 + | Ok () -> Ok (name, push_url) 307 + | Error e -> Error (name, push_url, Ctx.Git_error e)) 304 308 pushed_repos 305 309 306 310 let log_push_results push_results = 307 311 let successes, failures = 308 312 List.partition_map 309 - (function Ok name -> Left name | Error (name, _) -> Right name) 313 + (function 314 + | Ok (name, url) -> Left (name, url) 315 + | Error (name, url, _) -> Right (name, url)) 310 316 push_results 311 317 in 312 - List.iter (fun name -> Log.app (fun m -> m " ✓ %s" name)) successes; 313 - List.iter (fun name -> Log.app (fun m -> m " ✗ %s" name)) failures; 318 + List.iter 319 + (fun (name, url) -> Log.app (fun m -> m " ✓ %s → %s" name url)) 320 + successes; 321 + List.iter 322 + (fun (name, url) -> Log.app (fun m -> m " ✗ %s → %s" name url)) 323 + failures; 314 324 match List.find_opt Result.is_error push_results with 315 - | Some (Error (_, e)) -> Error e 325 + | Some (Error (_, _, e)) -> Error e 316 326 | _ -> Ok () 317 327 318 328 let repos_to_push statuses pkgs = ··· 491 501 if upstream && pushed_repos <> [] then 492 502 to_upstream ~sw ~proc ~fs:fs_t ~config ~sources ~force ~progress 493 503 pushed_repos 494 - else List.map (fun p -> Ok (Package.repo_name p)) pushed_repos 504 + else 505 + List.map 506 + (fun p -> 507 + let name = Package.repo_name p in 508 + let checkouts_root = Config.Paths.checkouts config in 509 + let url = 510 + Fpath.to_string (Package.checkout_dir ~checkouts_root p) 511 + in 512 + Ok (name, url)) 513 + pushed_repos 495 514 in 496 515 Tty.Progress.clear progress; 497 516 log_missing_repos ~all_pkgs missing; ··· 535 554 Log.info (fun m -> 536 555 m "Checking status of %d packages" (List.length pkgs)); 537 556 let statuses = Status.compute_all ~sw ~fs:fs_t ~config pkgs in 538 - let dirty = 539 - List.filter Status.has_local_changes statuses 540 - |> List.map (fun s -> s.Status.package) 541 - in 542 - if dirty <> [] then Error (Ctx.Dirty_state dirty) 543 - else begin 557 + (* Note: we do NOT block push on dirty checkouts. Checkouts under 558 + src/ are a derived cache; the authoritative state lives in the 559 + monorepo. Uncommitted edits to a checkout would be clobbered 560 + on the next pull anyway, and pushing from the monorepo never 561 + reads the checkout's worktree. Pull still guards against dirty 562 + checkouts because merging into one would destroy real work. *) 563 + begin 544 564 (* Sync opam files to opam-repo before pushing *) 545 565 (match Opam_sync.run ~sw ~fs:fs_t ~config ~packages () with 546 566 | Ok r ->

+6 -4

lib/status.mli

··· 24 24 | Present (** Subtree exists in monorepo *) 25 25 26 26 (** Sync state between monorepo subtree and local checkout. This distinguishes 27 - issues fixable with [monopam sync] from those requiring network access. *) 27 + issues fixable with [monopam pull]/[monopam push] from those requiring 28 + network access. *) 28 29 type subtree_sync = 29 30 | In_sync (** Subtree matches checkout HEAD *) 30 31 | Subtree_behind of int ··· 68 69 repo, and has no uncommitted changes). *) 69 70 70 71 val has_local_changes : t -> bool 71 - (** [has_local_changes t] returns true if either the checkout or subtree has 72 - uncommitted local changes. *) 72 + (** [has_local_changes t] returns true if the local checkout has uncommitted 73 + changes. The monorepo itself is not inspected. *) 73 74 74 75 val needs_pull : t -> bool 75 76 (** [needs_pull t] returns true if the checkout is behind the remote. *) ··· 79 80 80 81 val needs_local_sync : t -> bool 81 82 (** [needs_local_sync t] returns true if the monorepo subtree is out of sync 82 - with the local checkout. This can be fixed with [monopam sync]. *) 83 + with the local checkout. This can be fixed by running [monopam pull] or 84 + [monopam push] depending on direction. *) 83 85 84 86 val needs_remote_action : t -> bool 85 87 (** [needs_remote_action t] returns true if the checkout is ahead of or behind

+1 -1

lib/verse.mli

··· 184 184 ([verse/<handle>-opam/]), finds all packages sharing the same dev-repo, and 185 185 creates entries in your opam-repo with the fork URL as the dev-repo. 186 186 187 - After forking, run [monopam sync] to pull the fork into your monorepo. 187 + After forking, run [monopam pull] to pull the fork into your monorepo. 188 188 189 189 @param proc Eio process manager. 190 190 @param fs Eio filesystem.

+34 -9

test/push.t

··· 71 71 Basic push 72 72 ---------- 73 73 74 - First push should create the checkout and push to upstream: 74 + First push should create the checkout and push to its configured remote. 75 + The output shows the per-repo line (with URL) and the summary: 75 76 76 - $ monopam push mylib 2>&1 | tail -1 77 - ✓ Changes pushed to upstream in 0.1s. 77 + $ monopam push mylib 2>&1 \ 78 + > | grep -F "✓" \ 79 + > | sed 's|file://.*ocaml-mylib|file://<WS>/upstream/ocaml-mylib|' \ 80 + > | sed 's/ (.*//' 81 + ✓ ocaml-mylib → file://<WS>/upstream/ocaml-mylib 82 + ✓ Changes pushed to your remotes. 83 + 84 + And a "Next" hint guides the user to their next action: 85 + 86 + $ monopam push mylib 2>&1 | grep "Next:" 87 + Next: monopam status 78 88 79 89 $ test -d "$WS/src/ocaml-mylib/.git" && echo "checkout exists" 80 90 checkout exists ··· 87 97 88 98 $ echo "let x = 2" > ocaml-mylib/lib/main.ml 89 99 $ git add . && git commit -q -m "mylib: v2" 90 - $ monopam push mylib 2>&1 | tail -1 91 - ✓ Changes pushed to upstream in 0.1s. 100 + $ monopam push mylib 2>&1 | grep "Changes pushed" | sed 's/ (.*//' 101 + ✓ Changes pushed to your remotes. 92 102 93 103 $ cd "$WS/src/ocaml-mylib" && git log --format="%s" && cd "$WS/mono" 94 104 mylib: v2 ··· 101 111 $ export GIT_AUTHOR_EMAIL="bob@example.com" 102 112 $ echo "let x = 3" > ocaml-mylib/lib/main.ml 103 113 $ git add . && git commit -q -m "mylib: v3 by Bob" 104 - $ monopam push mylib 2>&1 | tail -1 105 - ✓ Changes pushed to upstream in 0.1s. 114 + $ monopam push mylib 2>&1 | grep "Changes pushed" | sed 's/ (.*//' 115 + ✓ Changes pushed to your remotes. 106 116 107 117 $ cd "$WS/src/ocaml-mylib" && git log -1 --format="%an <%ae> %s" && cd "$WS/mono" 108 118 Bob <bob@example.com> mylib: v3 by Bob ··· 141 151 142 152 $ echo "let x = 4" > ocaml-mylib/lib/main.ml 143 153 $ git add . && git commit -q -m "mylib: v4" 144 - $ monopam push mylib 2>&1 | tail -1 145 - ✓ Changes pushed to upstream in 0.1s. 154 + $ monopam push mylib 2>&1 | grep "Changes pushed" | sed 's/ (.*//' 155 + ✓ Changes pushed to your remotes. 146 156 147 157 $ cd "$WS/src/ocaml-mylib" && git log --format="%s" | head -2 && cd "$WS/mono" 148 158 mylib: v4 149 159 mylib: v3 by Bob 160 + 161 + Push over a dirty checkout 162 + -------------------------- 163 + 164 + Checkouts under src/ are a derived cache. Uncommitted edits inside the 165 + checkout must not block a push from the monorepo. 166 + 167 + $ echo "stray" > "$WS/src/ocaml-mylib/lib/scratch.ml" 168 + $ echo "let x = 5" > ocaml-mylib/lib/main.ml 169 + $ git add . && git commit -q -m "mylib: v5" 170 + $ monopam push mylib 2>&1 | grep "Changes pushed" | sed 's/ (.*//' 171 + ✓ Changes pushed to your remotes. 172 + 173 + $ cd "$WS/src/ocaml-mylib" && git log --format="%s" | head -1 && cd "$WS/mono" 174 + mylib: v5

+130

test/quickstart.t

··· 1 + Quick Start End-to-end 2 + ======================= 3 + 4 + Regression test for the documented README Quick Start. A new user 5 + following the README cold should be able to create a workspace with 6 + `monopam init`, add an existing upstream package by URL, edit in the 7 + monorepo, commit, and push — upstream should receive both the imported 8 + history AND the new commit, as a fast-forward, without needing --force. 9 + The test fails loudly if any step regresses; the quickstart is the 10 + tool's first impression, so it must survive every refactor. 11 + 12 + Setup 13 + ----- 14 + 15 + $ export NO_COLOR=1 16 + $ export GIT_AUTHOR_NAME="Alice" 17 + $ export GIT_AUTHOR_EMAIL="alice@example.com" 18 + $ export GIT_AUTHOR_DATE="2025-01-01T00:00:00+00:00" 19 + $ export GIT_COMMITTER_NAME="Alice" 20 + $ export GIT_COMMITTER_EMAIL="alice@example.com" 21 + $ export GIT_COMMITTER_DATE="2025-01-01T00:00:00+00:00" 22 + $ export HOME="$PWD/home" 23 + $ mkdir -p "$HOME" 24 + $ export GIT_CONFIG_GLOBAL="$HOME/.gitconfig" 25 + $ printf '[init]\n\tdefaultBranch = main\n[user]\n\tname = Alice\n\temail = alice@example.com\n' > "$GIT_CONFIG_GLOBAL" 26 + $ TROOT=$(pwd) 27 + 28 + Create an upstream repository that already has one commit. This 29 + stands in for a real project the user has on github or tangled. 30 + 31 + $ git init -q --bare upstream.git 32 + $ git clone -q upstream.git upstream-work 2>/dev/null 33 + $ cd upstream-work 34 + $ echo "let greet () = print_endline \"hi\"" > lib.ml 35 + $ cat > lib.opam << OPAM 36 + > opam-version: "2.0" 37 + > name: "lib" 38 + > version: "dev" 39 + > synopsis: "A quickstart library" 40 + > dev-repo: "git+file://$TROOT/upstream.git" 41 + > OPAM 42 + $ git add . && git commit -q -m "initial" 43 + $ git push -q origin main 2>/dev/null 44 + $ cd "$TROOT" 45 + 46 + Create the opam-repo overlay so the workspace knows about `lib`: 47 + 48 + $ mkdir -p opam-repo/packages/lib/lib.dev 49 + $ cp upstream-work/lib.opam opam-repo/packages/lib/lib.dev/opam 50 + $ cd opam-repo && git init -q && git add . && git commit -q -m "init" && cd "$TROOT" 51 + 52 + Configure monopam to find this workspace: 53 + 54 + $ mkdir -p "$HOME/.config/monopam" 55 + $ cat > "$HOME/.config/monopam/opamverse.toml" << EOF 56 + > [workspace] 57 + > root = "$TROOT" 58 + > [identity] 59 + > handle = "alice.example.org" 60 + > knot = "git.example.org" 61 + > EOF 62 + 63 + Create the monorepo directory. In a real workflow this would be 64 + created by [monopam init]; here we just create it directly. 65 + 66 + $ mkdir mono && cd mono 67 + $ git init -q && git commit -q --allow-empty -m "init monorepo" 68 + 69 + Step 1: monopam add URL 70 + ------------------------ 71 + 72 + Adding pulls the upstream history into the monorepo as a subtree 73 + and writes the metadata to sources.toml. The success line lists the 74 + imported subtree with its commit hash. 75 + 76 + $ monopam add "$TROOT/upstream.git" 2>&1 \ 77 + > | sed '/Added/ s/ (.*$//' \ 78 + > | sed 's/at [0-9a-f]*$/at <SHA>/' \ 79 + > | sed 's/(upstream \?([0-9a-f]*)/(upstream (<SHA>)/' \ 80 + > | sed -E 's/\+ upstream $[0-9a-f]+$/+ upstream (<SHA>)/' 81 + Imported upstream at <SHA> 82 + Updated dune-project with 0 external dependencies 83 + + upstream (<SHA>) 84 + ✓ Added 1 subtree. 85 + Next: dune build && dune test 86 + 87 + The HEAD commit must contain the subtree (this is a regression 88 + assertion: [add] used to commit with a stale index, silently losing 89 + the imported subtree from HEAD): 90 + 91 + $ git ls-tree HEAD | awk '{print $2, $4}' | sort 92 + blob sources.toml 93 + tree upstream 94 + 95 + Step 2: edit and commit 96 + ----------------------- 97 + 98 + The user modifies a file in the subtree and commits. This is a 99 + plain git commit — nothing monopam-specific: 100 + 101 + $ export GIT_AUTHOR_DATE="2025-01-02T00:00:00+00:00" 102 + $ export GIT_COMMITTER_DATE="2025-01-02T00:00:00+00:00" 103 + $ echo 'let bye () = print_endline "bye"' >> upstream/lib.ml 104 + $ git add upstream/lib.ml && git commit -q -m "upstream: add bye" 105 + 106 + Step 3: monopam push 107 + --------------------- 108 + 109 + Push sends the new commit back to the upstream remote. Crucially, 110 + this is a fast-forward: monopam never needs [--force] to push the 111 + first edit after an [add]. The output shows the per-repo line with 112 + its URL and a summary with a next-step hint. 113 + 114 + $ monopam push lib 2>&1 \ 115 + > | grep -F "✓" \ 116 + > | sed 's|→ .*upstream.git|→ <URL>/upstream.git|' \ 117 + > | sed 's/ (.*//' 118 + ✓ upstream → <URL>/upstream.git 119 + ✓ Changes pushed to your remotes. 120 + 121 + Verify the edit actually landed in the upstream bare repo — both 122 + commits should be present, with the new "add bye" on top of the 123 + preserved "initial": 124 + 125 + $ cd "$TROOT" && rm -rf verify && git clone -q upstream.git verify 126 + $ cd verify && git log --format="%s" && cat lib.ml 127 + upstream: add bye 128 + initial 129 + let greet () = print_endline "hi" 130 + let bye () = print_endline "bye"

+72 -3

test/sources.t

··· 43 43 $ git init -q 44 44 $ git commit -q --allow-empty -m "init monorepo" 45 45 46 - $ monopam add "$TROOT/upstream-lib.git" 2>&1 46 + $ monopam add "$TROOT/upstream-lib.git" 2>&1 | sed '/Added/ s/ (.*$//' 47 47 Imported upstream-lib at 66f5f30 48 48 Updated dune-project with 0 external dependencies 49 - Added 1 subtree: 50 - upstream-lib (66f5f30) 49 + + upstream-lib (66f5f30) 50 + ✓ Added 1 subtree. 51 + Next: dune build && dune test 51 52 52 53 Verify sources.toml has source and ref fields: 53 54 ··· 69 70 1 70 71 71 72 $ cd "$TROOT" 73 + 74 + Add by opam package name resolves via local overlay 75 + ----------------------------------------------------- 76 + 77 + When the argument is not a URL (no slashes, no scheme), monopam treats 78 + it as an opam package name and looks it up in the local opam-repo 79 + overlay. This exercises the resolver and prints the URL it used. 80 + 81 + Create another upstream repo and a minimal opam-repo pointing at it: 82 + 83 + $ git init -q --bare tool.git 84 + $ git clone -q tool.git tool-work 2>/dev/null 85 + $ cd tool-work 86 + $ cat > dune-project << 'DUNE' 87 + > (lang dune 3.21) 88 + > (name tool) 89 + > DUNE 90 + $ cat > tool.opam << OPAM 91 + > opam-version: "2.0" 92 + > name: "tool" 93 + > synopsis: "Resolved by name" 94 + > dev-repo: "git+file://$TROOT/tool.git" 95 + > OPAM 96 + $ git add . && git commit -q -m "initial" 97 + $ git push -q origin main 2>/dev/null 98 + $ cd "$TROOT" 99 + 100 + $ mkdir -p opam-repo/packages/tool/tool.dev 101 + $ cp tool-work/tool.opam opam-repo/packages/tool/tool.dev/opam 102 + $ cd opam-repo && git init -q && git add . && git commit -q -m "init" && cd "$TROOT" 103 + 104 + Configure monopam to see that opam-repo: 105 + 106 + $ mkdir -p "$HOME/.config/monopam" 107 + $ cat > "$HOME/.config/monopam/opamverse.toml" << EOF 108 + > [workspace] 109 + > root = "$TROOT" 110 + > [identity] 111 + > handle = "test.example.org" 112 + > knot = "git.example.org" 113 + > EOF 114 + 115 + Add by name — note: no URL, no slashes, plain opam name: 116 + 117 + $ mkdir mono2 && cd mono2 && git init -q && git commit -q --allow-empty -m "init" 118 + $ monopam add tool 2>&1 \ 119 + > | sed '/Added/ s/ (.*$//' \ 120 + > | sed 's|resolved tool to .*|resolved tool to <URL>|' \ 121 + > | sed 's/ at [0-9a-f]*$/ at <SHA>/' \ 122 + > | sed 's/+ tool (.*)/+ tool (<SHA>)/' \ 123 + > | head -4 124 + [add] resolved tool to <URL> 125 + Imported tool at <SHA> 126 + Updated dune-project with 0 external dependencies 127 + + tool (<SHA>) 128 + 129 + $ grep '\[tool\]' sources.toml 130 + [tool] 131 + $ cd "$TROOT" 132 + 133 + Add by unknown name produces a hint 134 + ------------------------------------ 135 + 136 + $ mkdir mono3 && cd mono3 && git init -q && git commit -q --allow-empty -m "init" 137 + $ monopam add nonexistent-pkg-xyz 2>&1 | head -2 138 + Error: No dev-repo found for package "nonexistent-pkg-xyz". Tried the local opam-repo overlay and `opam show`. Pass a git URL directly to bypass resolution. 139 + Hint: Pass a git URL (e.g. https://github.com/owner/repo.git) or install the package first so `opam show` can locate its dev-repo field. 140 + $ cd "$TROOT"

-1

test/test.ml

··· 14 14 Test_ctx.suite; 15 15 Test_deps.suite; 16 16 Test_diff.suite; 17 - Test_doctor.suite; 18 17 Test_dune_project.suite; 19 18 Test_feature.suite; 20 19 Test_fork_join.suite;

+31

test/test_config.ml

··· 132 132 let test_default_branch () = 133 133 Alcotest.(check string) "default branch is main" "main" Config.default_branch 134 134 135 + (* Test load_error pretty-printing. Each variant must produce a distinct 136 + user-visible prefix so that Common.with_config can pattern-match on the 137 + variant to pick the right hint. *) 138 + 139 + let test_pp_load_error_not_found () = 140 + let err = Config.Not_found (Fpath.v "/tmp/nope.toml") in 141 + let msg = Fmt.str "%a" Config.pp_load_error err in 142 + Alcotest.(check bool) 143 + "not-found prefix" true 144 + (String.length msg >= 20 && String.sub msg 0 20 = "Config file not foun") 145 + 146 + let test_pp_load_error_invalid () = 147 + let err = Config.Invalid { path = Fpath.v "/tmp/bad.toml"; msg = "syntax" } in 148 + let msg = Fmt.str "%a" Config.pp_load_error err in 149 + Alcotest.(check bool) 150 + "invalid prefix" true 151 + (String.length msg >= 14 && String.sub msg 0 14 = "Invalid config") 152 + 153 + let test_pp_load_error_io () = 154 + let err = 155 + Config.Io_error { path = Fpath.v "/tmp/unreadable.toml"; msg = "EACCES" } 156 + in 157 + let msg = Fmt.str "%a" Config.pp_load_error err in 158 + Alcotest.(check bool) 159 + "io-error prefix" true 160 + (String.length msg >= 17 && String.sub msg 0 17 = "Error reading con") 161 + 135 162 let suite = 136 163 ( "config", 137 164 [ ··· 148 175 Alcotest.test_case "with override" `Quick test_with_package_override; 149 176 Alcotest.test_case "update override" `Quick test_override_update; 150 177 Alcotest.test_case "default branch" `Quick test_default_branch; 178 + Alcotest.test_case "load_error: not found" `Quick 179 + test_pp_load_error_not_found; 180 + Alcotest.test_case "load_error: invalid" `Quick test_pp_load_error_invalid; 181 + Alcotest.test_case "load_error: io" `Quick test_pp_load_error_io; 151 182 ] )

+73

test/test_ctx.ml

··· 94 94 let result = Ctx.url_to_push_url "git+https://github.com/user/repo.git" in 95 95 Alcotest.(check string) "strips git+" "git@github.com:user/repo.git" result 96 96 97 + (* {1 exit_code tests} 98 + 99 + Each error category must land on a distinct shell exit code so 100 + scripts can tell user errors from network issues, conflicts, and 101 + external-service failures. *) 102 + 103 + let make_cmd_failed ?(stderr = "") ?(stdout = "") ?(exit = 128) cmd = 104 + Ctx.Git_error 105 + (Monopam.Git_cli.Command_failed 106 + (cmd, Monopam.Git_cli.{ exit_code = exit; stdout; stderr })) 107 + 108 + let test_exit_user_error () = 109 + Alcotest.(check int) "config" 2 (Ctx.exit_code (Ctx.Config_error "x")); 110 + Alcotest.(check int) "monorepo dirty" 2 (Ctx.exit_code Ctx.Monorepo_dirty); 111 + Alcotest.(check int) 112 + "package not found" 2 113 + (Ctx.exit_code (Ctx.Package_not_found "x")); 114 + Alcotest.(check int) 115 + "other" 2 116 + (Ctx.exit_code (Ctx.err ~hint:"try again" "something")) 117 + 118 + let test_exit_git_user_error () = 119 + Alcotest.(check int) 120 + "not a repo" 2 121 + (Ctx.exit_code 122 + (Ctx.Git_error (Monopam.Git_cli.Not_a_repo (Fpath.v "/tmp/x")))); 123 + Alcotest.(check int) 124 + "dirty worktree" 2 125 + (Ctx.exit_code 126 + (Ctx.Git_error (Monopam.Git_cli.Dirty_worktree (Fpath.v "/tmp/x")))); 127 + Alcotest.(check int) 128 + "subtree missing" 2 129 + (Ctx.exit_code 130 + (Ctx.Git_error (Monopam.Git_cli.Subtree_prefix_missing "eio"))) 131 + 132 + let test_exit_network () = 133 + Alcotest.(check int) 134 + "git io_error" 3 135 + (Ctx.exit_code (Ctx.Git_error (Monopam.Git_cli.Io_error "boom"))); 136 + Alcotest.(check int) 137 + "git push unreachable" 3 138 + (Ctx.exit_code 139 + (make_cmd_failed "git push origin main" 140 + ~stderr:"fatal: Could not resolve host: github.com")); 141 + Alcotest.(check int) 142 + "git fetch timeout" 3 143 + (Ctx.exit_code 144 + (make_cmd_failed "git fetch origin" 145 + ~stderr:"fatal: unable to access 'https://...': Connection refused")) 146 + 147 + let test_exit_conflict () = 148 + Alcotest.(check int) 149 + "non-fast-forward" 4 150 + (Ctx.exit_code 151 + (make_cmd_failed "git push origin main" 152 + ~stderr:"! [rejected] main -> main (non-fast-forward)")); 153 + Alcotest.(check int) 154 + "fetch first" 4 155 + (Ctx.exit_code 156 + (make_cmd_failed "git push origin main" 157 + ~stderr:"error: hint: Updates were rejected... fetch first")) 158 + 159 + let test_exit_external () = 160 + Alcotest.(check int) 161 + "claude" 5 162 + (Ctx.exit_code (Ctx.Claude_error "api timeout")) 163 + 97 164 let suite = 98 165 ( "ctx", 99 166 [ ··· 120 187 Alcotest.test_case "push ssh passthrough" `Quick 121 188 test_push_url_ssh_passthrough; 122 189 Alcotest.test_case "push strips git+" `Quick test_push_url_strips_git_plus; 190 + (* exit_code *) 191 + Alcotest.test_case "exit user error" `Quick test_exit_user_error; 192 + Alcotest.test_case "exit git user error" `Quick test_exit_git_user_error; 193 + Alcotest.test_case "exit network" `Quick test_exit_network; 194 + Alcotest.test_case "exit conflict" `Quick test_exit_conflict; 195 + Alcotest.test_case "exit external service" `Quick test_exit_external; 123 196 ] )

-175

test/test_doctor.ml

··· 1 - (* Tests for doctor module *) 2 - 3 - module Doctor = Monopam.Doctor 4 - 5 - (* {1 health_to_exit_code tests} *) 6 - 7 - let test_healthy_exit_code () = 8 - Alcotest.(check int) "healthy" 0 (Doctor.health_to_exit_code Doctor.Healthy) 9 - 10 - let test_warning_exit_code () = 11 - Alcotest.(check int) "warning" 1 (Doctor.health_to_exit_code Doctor.Warning) 12 - 13 - let test_critical_exit_code () = 14 - Alcotest.(check int) "critical" 2 (Doctor.health_to_exit_code Doctor.Critical) 15 - 16 - (* {1 compute_health tests} *) 17 - 18 - let empty_summary : Doctor.report_summary = 19 - { 20 - repos_total = 5; 21 - repos_need_sync = 0; 22 - repos_behind_upstream = 0; 23 - verse_divergences = 0; 24 - } 25 - 26 - let mk_report ?(summary = empty_summary) ?(repos = []) ?(recommendations = []) 27 - ?(warnings = []) () : Doctor.report = 28 - { 29 - timestamp = "2026-03-16T12:00:00Z"; 30 - workspace = "/tmp/test"; 31 - report_summary = summary; 32 - repos; 33 - recommendations; 34 - warnings; 35 - } 36 - 37 - let test_compute_health_healthy () = 38 - let report = mk_report () in 39 - Alcotest.(check int) 40 - "healthy" 0 41 - (Doctor.health_to_exit_code (Doctor.compute_health report)) 42 - 43 - let test_compute_health_warning_sync () = 44 - let summary = { empty_summary with repos_need_sync = 2 } in 45 - let report = mk_report ~summary () in 46 - Alcotest.(check int) 47 - "warning" 1 48 - (Doctor.health_to_exit_code (Doctor.compute_health report)) 49 - 50 - let test_compute_health_warning_behind () = 51 - let summary = { empty_summary with repos_behind_upstream = 1 } in 52 - let report = mk_report ~summary () in 53 - Alcotest.(check int) 54 - "warning" 1 55 - (Doctor.health_to_exit_code (Doctor.compute_health report)) 56 - 57 - let test_compute_health_warning_diverged () = 58 - let summary = { empty_summary with verse_divergences = 3 } in 59 - let report = mk_report ~summary () in 60 - Alcotest.(check int) 61 - "warning" 1 62 - (Doctor.health_to_exit_code (Doctor.compute_health report)) 63 - 64 - let test_compute_health_critical_warnings () = 65 - let report = mk_report ~warnings:[ "something is wrong" ] () in 66 - Alcotest.(check int) 67 - "critical" 2 68 - (Doctor.health_to_exit_code (Doctor.compute_health report)) 69 - 70 - let test_compute_health_critical_recommendation () = 71 - let action : Doctor.action = 72 - { 73 - action_priority = Doctor.Critical; 74 - description = "Fix now"; 75 - command = Some "monopam sync"; 76 - } 77 - in 78 - let report = mk_report ~recommendations:[ action ] () in 79 - Alcotest.(check int) 80 - "critical" 2 81 - (Doctor.health_to_exit_code (Doctor.compute_health report)) 82 - 83 - (* {1 has_issues tests} *) 84 - 85 - let test_has_issues_none () = 86 - Alcotest.(check bool) "no issues" false (Doctor.has_issues (mk_report ())) 87 - 88 - let test_has_issues_sync () = 89 - let summary = { empty_summary with repos_need_sync = 1 } in 90 - Alcotest.(check bool) 91 - "sync needed" true 92 - (Doctor.has_issues (mk_report ~summary ())) 93 - 94 - let test_has_issues_behind () = 95 - let summary = { empty_summary with repos_behind_upstream = 1 } in 96 - Alcotest.(check bool) 97 - "behind" true 98 - (Doctor.has_issues (mk_report ~summary ())) 99 - 100 - let test_has_issues_warnings () = 101 - Alcotest.(check bool) 102 - "warnings" true 103 - (Doctor.has_issues (mk_report ~warnings:[ "w" ] ())) 104 - 105 - let test_has_issues_recommendations () = 106 - let action : Doctor.action = 107 - { action_priority = Doctor.Low; description = "Consider X"; command = None } 108 - in 109 - Alcotest.(check bool) 110 - "recommendations" true 111 - (Doctor.has_issues (mk_report ~recommendations:[ action ] ())) 112 - 113 - (* {1 pp tests} *) 114 - 115 - let test_pp_priority () = 116 - let s = Fmt.str "%a" Doctor.pp_priority Doctor.Critical in 117 - Alcotest.(check bool) "non-empty" true (String.length s > 0) 118 - 119 - let test_pp_category () = 120 - let s = Fmt.str "%a" Doctor.pp_category Doctor.Bug_fix in 121 - Alcotest.(check bool) "non-empty" true (String.length s > 0) 122 - 123 - let test_pp_recommendation () = 124 - let s = Fmt.str "%a" Doctor.pp_recommendation Doctor.Merge_now in 125 - Alcotest.(check bool) "non-empty" true (String.length s > 0) 126 - 127 - let test_pp_conflict_risk () = 128 - let s = Fmt.str "%a" Doctor.pp_conflict_risk Doctor.None_risk in 129 - Alcotest.(check bool) "non-empty" true (String.length s > 0) 130 - 131 - let test_pp_report () = 132 - let report = mk_report () in 133 - let s = Fmt.str "%a" Doctor.pp_report report in 134 - Alcotest.(check bool) "non-empty" true (String.length s > 0) 135 - 136 - (* {1 JSON roundtrip} *) 137 - 138 - let test_to_json () = 139 - let report = mk_report () in 140 - let json = Doctor.to_json report in 141 - Alcotest.(check bool) "non-empty JSON" true (String.length json > 0) 142 - 143 - let suite = 144 - ( "doctor", 145 - [ 146 - (* exit codes *) 147 - Alcotest.test_case "healthy exit" `Quick test_healthy_exit_code; 148 - Alcotest.test_case "warning exit" `Quick test_warning_exit_code; 149 - Alcotest.test_case "critical exit" `Quick test_critical_exit_code; 150 - (* compute_health *) 151 - Alcotest.test_case "health healthy" `Quick test_compute_health_healthy; 152 - Alcotest.test_case "health sync" `Quick test_compute_health_warning_sync; 153 - Alcotest.test_case "health behind" `Quick 154 - test_compute_health_warning_behind; 155 - Alcotest.test_case "health diverged" `Quick 156 - test_compute_health_warning_diverged; 157 - Alcotest.test_case "health critical warn" `Quick 158 - test_compute_health_critical_warnings; 159 - Alcotest.test_case "health critical rec" `Quick 160 - test_compute_health_critical_recommendation; 161 - (* has_issues *) 162 - Alcotest.test_case "no issues" `Quick test_has_issues_none; 163 - Alcotest.test_case "issues sync" `Quick test_has_issues_sync; 164 - Alcotest.test_case "issues behind" `Quick test_has_issues_behind; 165 - Alcotest.test_case "issues warnings" `Quick test_has_issues_warnings; 166 - Alcotest.test_case "issues recs" `Quick test_has_issues_recommendations; 167 - (* pp *) 168 - Alcotest.test_case "pp priority" `Quick test_pp_priority; 169 - Alcotest.test_case "pp category" `Quick test_pp_category; 170 - Alcotest.test_case "pp recommendation" `Quick test_pp_recommendation; 171 - Alcotest.test_case "pp conflict_risk" `Quick test_pp_conflict_risk; 172 - Alcotest.test_case "pp report" `Quick test_pp_report; 173 - (* JSON *) 174 - Alcotest.test_case "to_json" `Quick test_to_json; 175 - ] )

-2

test/test_doctor.mli

··· 1 - val suite : string * unit Alcotest.test_case list 2 - (** Test suite. *)

+51

test/test_import.ml

··· 60 60 (* Should be ISO-ish format with at least year-month-day *) 61 61 Alcotest.(check bool) "has year" true (String.length ts >= 10) 62 62 63 + (* {1 looks_like_url tests} *) 64 + 65 + let test_looks_like_url_https () = 66 + Alcotest.(check bool) 67 + "https is url" true 68 + (Import.looks_like_url "https://github.com/owner/repo.git") 69 + 70 + let test_looks_like_url_git_at () = 71 + Alcotest.(check bool) 72 + "git@ is url" true 73 + (Import.looks_like_url "git@github.com:owner/repo.git") 74 + 75 + let test_looks_like_url_git_plus () = 76 + Alcotest.(check bool) 77 + "git+ is url" true 78 + (Import.looks_like_url "git+https://example.com/repo") 79 + 80 + let test_looks_like_url_local_path () = 81 + Alcotest.(check bool) 82 + "local path is url" true 83 + (Import.looks_like_url "./local/repo") 84 + 85 + let test_looks_like_url_dot_git () = 86 + Alcotest.(check bool) 87 + "trailing .git is url" true 88 + (Import.looks_like_url "myrepo.git") 89 + 90 + let test_looks_like_url_bare_name () = 91 + (* Opam package name — NOT a URL *) 92 + Alcotest.(check bool) 93 + "plain name is not url" false 94 + (Import.looks_like_url "crowbar") 95 + 96 + let test_looks_like_url_hyphen_name () = 97 + Alcotest.(check bool) 98 + "hyphenated name is not url" false 99 + (Import.looks_like_url "opam-file-format") 100 + 63 101 let suite = 64 102 ( "import", 65 103 [ ··· 77 115 Alcotest.test_case "normalize http" `Quick test_normalize_http; 78 116 (* timestamp *) 79 117 Alcotest.test_case "timestamp format" `Quick test_timestamp_format; 118 + (* looks_like_url *) 119 + Alcotest.test_case "looks_like_url https" `Quick test_looks_like_url_https; 120 + Alcotest.test_case "looks_like_url git@" `Quick test_looks_like_url_git_at; 121 + Alcotest.test_case "looks_like_url git+" `Quick 122 + test_looks_like_url_git_plus; 123 + Alcotest.test_case "looks_like_url local path" `Quick 124 + test_looks_like_url_local_path; 125 + Alcotest.test_case "looks_like_url .git" `Quick 126 + test_looks_like_url_dot_git; 127 + Alcotest.test_case "looks_like_url plain name" `Quick 128 + test_looks_like_url_bare_name; 129 + Alcotest.test_case "looks_like_url hyphen name" `Quick 130 + test_looks_like_url_hyphen_name; 80 131 ] )

+14 -17

test/workflow.t

··· 35 35 $ mkdir empty && cd empty 36 36 $ git init -q 37 37 $ monopam status 2>&1 38 - Error loading config: Config file not found: $TESTCASE_ROOT/home/.config/monopam/opamverse.toml 39 - Run 'monopam init' first to create a workspace. 40 - monopam: configuration error 41 - [124] 38 + Error: Config file not found: $TESTCASE_ROOT/home/.config/monopam/opamverse.toml 39 + Hint: Run 'monopam init --handle <your-handle>' to create a workspace. 40 + [2] 42 41 $ cd .. 43 42 44 43 Basic status on a fresh monorepo ··· 60 59 Status shows no packages found (need proper monopam structure): 61 60 62 61 $ monopam status 2>&1 63 - Error loading config: Config file not found: $TESTCASE_ROOT/home/.config/monopam/opamverse.toml 64 - Run 'monopam init' first to create a workspace. 65 - monopam: configuration error 66 - [124] 62 + Error: Config file not found: $TESTCASE_ROOT/home/.config/monopam/opamverse.toml 63 + Hint: Run 'monopam init --handle <your-handle>' to create a workspace. 64 + [2] 67 65 $ cd .. 68 66 69 67 Diff command ··· 78 76 Diff on clean repo shows no output: 79 77 80 78 $ monopam diff 2>&1 | head -3 81 - Error loading config: Config file not found: $TESTCASE_ROOT/home/.config/monopam/opamverse.toml 82 - Run 'monopam init' first to create a workspace. 83 - monopam: configuration error 79 + Error: Config file not found: $TESTCASE_ROOT/home/.config/monopam/opamverse.toml 80 + Hint: Run 'monopam init --handle <your-handle>' to create a workspace. 84 81 $ cd .. 85 82 86 83 Pull command requires packages ··· 91 88 $ echo "test" > README.md 92 89 $ git add . && git commit -q -m "init" 93 90 $ monopam pull 2>&1 | head -2 94 - Error loading config: Config file not found: $TESTCASE_ROOT/home/.config/monopam/opamverse.toml 95 - Run 'monopam init' first to create a workspace. 91 + Error: Config file not found: $TESTCASE_ROOT/home/.config/monopam/opamverse.toml 92 + Hint: Run 'monopam init --handle <your-handle>' to create a workspace. 96 93 $ cd .. 97 94 98 95 Push command requires packages ··· 103 100 $ echo "test" > README.md 104 101 $ git add . && git commit -q -m "init" 105 102 $ monopam push 2>&1 | head -2 106 - Error loading config: Config file not found: $TESTCASE_ROOT/home/.config/monopam/opamverse.toml 107 - Run 'monopam init' first to create a workspace. 103 + Error: Config file not found: $TESTCASE_ROOT/home/.config/monopam/opamverse.toml 104 + Hint: Run 'monopam init --handle <your-handle>' to create a workspace. 108 105 $ cd .. 109 106 110 107 Fetch command requires packages ··· 115 112 $ echo "test" > README.md 116 113 $ git add . && git commit -q -m "init" 117 114 $ monopam fetch 2>&1 | head -2 118 - Error loading config: Config file not found: $TESTCASE_ROOT/home/.config/monopam/opamverse.toml 119 - Run 'monopam init' first to create a workspace. 115 + Error: Config file not found: $TESTCASE_ROOT/home/.config/monopam/opamverse.toml 116 + Hint: Run 'monopam init --handle <your-handle>' to create a workspace. 120 117 $ cd ..

Configure Feed

Configure Feed