+9 -1

bin/dune

reviewed

··· 2 2 (name main) 3 3 (public_name monopam) 4 4 (package monopam) 5 5 - (libraries monopam requests eio_main cmdliner fmt.tty fmt.cli logs.fmt logs.cli)) 5 5 + (libraries 6 6 + monopam 7 7 + requests 8 8 + eio_main 9 9 + cmdliner 10 10 + fmt.tty 11 11 + fmt.cli 12 12 + logs.fmt 13 13 + logs.cli))

+1074 -329

bin/main.ml

reviewed

··· 12 12 13 13 let logging_term = 14 14 let verbose_http_term = 15 15 - Term.(const (fun ws -> ws.Requests.Cmd.value) $ Requests.Cmd.verbose_http_term "monopam") 15 15 + Term.( 16 16 + const (fun ws -> ws.Requests.Cmd.value) 17 17 + $ Requests.Cmd.verbose_http_term "monopam") 16 18 in 17 17 - Term.(const setup_logging $ Fmt_cli.style_renderer () $ Logs_cli.level () $ verbose_http_term) 19 19 + Term.( 20 20 + const setup_logging $ Fmt_cli.style_renderer () $ Logs_cli.level () 21 21 + $ verbose_http_term) 18 22 19 23 let package_arg = 20 24 let doc = "Package name. If not specified, operates on all packages." in 21 25 Arg.(value & pos 0 (some string) None & info [] ~docv:"PACKAGE" ~doc) 22 26 23 23 - (* Load config from opamverse.toml and convert to Monopam.Config *) 27 27 + (* Load config from opamverse.toml *) 24 28 let load_config env = 25 29 let fs = Eio.Stdenv.fs env in 26 26 - match Monopam.Verse_config.load ~fs () with 27 27 - | Error msg -> Error msg 28 28 - | Ok verse_config -> 29 29 - (* Convert Verse_config to Monopam.Config *) 30 30 - let opam_repo = Monopam.Verse_config.opam_repo_path verse_config in 31 31 - let checkouts = Monopam.Verse_config.src_path verse_config in 32 32 - let monorepo = Monopam.Verse_config.mono_path verse_config in 33 33 - let default_branch = Monopam.Verse_config.default_branch in 34 34 - Ok (Monopam.Config.create ~opam_repo ~checkouts ~monorepo ~default_branch ()) 30 30 + Monopam.Config.load ~fs () 35 31 36 32 let with_config env f = 37 33 match load_config env with 38 34 | Ok config -> f config 39 35 | Error msg -> 40 36 Fmt.epr "Error loading config: %s@." msg; 41 41 - Fmt.epr "Run 'monopam verse init' first to create a workspace.@."; 37 37 + Fmt.epr "Run 'monopam init' first to create a workspace.@."; 42 38 `Error (false, "configuration error") 43 39 44 40 (* Status command *) ··· 57 53 `I ("remote:", "Sync between your checkout (src/) and upstream git remote"); 58 54 `S "LOCAL SYNC INDICATORS"; 59 55 `I ("local:=", "Monorepo and checkout are in sync"); 60 60 - `I ("local:+N", "Monorepo has N commits not yet in checkout (run $(b,monopam sync))"); 61 61 - `I ("local:-N", "Checkout has N commits not yet in monorepo (run $(b,monopam sync))"); 56 56 + `I 57 57 + ( "local:+N", 58 58 + "Monorepo has N commits not yet in checkout (run $(b,monopam sync))" 59 59 + ); 60 60 + `I 61 61 + ( "local:-N", 62 62 + "Checkout has N commits not yet in monorepo (run $(b,monopam sync))" 63 63 + ); 62 64 `I ("local:sync", "Trees differ, needs sync (run $(b,monopam sync))"); 63 65 `S "REMOTE SYNC INDICATORS"; 64 66 `I ("remote:=", "Checkout and upstream remote are in sync"); 65 65 - `I ("remote:+N", "Checkout has N commits to push (run $(b,monopam sync --remote))"); 67 67 + `I 68 68 + ( "remote:+N", 69 69 + "Checkout has N commits to push (run $(b,monopam sync --remote))" ); 66 70 `I ("remote:-N", "Upstream has N commits to pull (run $(b,monopam sync))"); 67 71 `I ("remote:+N/-M", "Diverged: checkout +N ahead, upstream +M ahead"); 68 72 `S "FORK ANALYSIS"; ··· 90 94 let proc = Eio.Stdenv.process_mgr env in 91 95 match Monopam.status ~proc ~fs ~config () with 92 96 | Ok statuses -> 93 93 - Fmt.pr "%a" Monopam.Status.pp_summary statuses; 97 97 + (* Load sources.toml for origin indicators *) 98 98 + let sources = 99 99 + let mono_path = Monopam.Config.Paths.monorepo config in 100 100 + let sources_path = Fpath.(mono_path / "sources.toml") in 101 101 + match Monopam.Sources_registry.load ~fs:(fs :> _ Eio.Path.t) sources_path with 102 102 + | Ok s -> Some s 103 103 + | Error _ -> None 104 104 + in 105 105 + Fmt.pr "%a" (Monopam.Status.pp_summary ?sources) statuses; 94 106 (* Check for unregistered opam files *) 95 107 (match Monopam.discover_packages ~fs ~config () with 96 108 | Ok pkgs -> 97 97 - let unregistered = Monopam.find_unregistered_opam_files ~fs ~config pkgs in 109 109 + let unregistered = 110 110 + Monopam.find_unregistered_opam_files ~fs ~config pkgs 111 111 + in 98 112 if unregistered <> [] then begin 99 113 (* Get local handle abbreviation *) 100 100 - let handle_abbrev = match Monopam.Verse_config.load ~fs () with 101 101 - | Ok vc -> 114 114 + let handle_abbrev = 115 115 + match Monopam.Verse_config.load ~fs () with 116 116 + | Ok vc -> ( 102 117 let h = Monopam.Verse_config.handle vc in 103 103 - (match String.split_on_char '.' h with 104 104 - | first :: _ -> if String.length first <= 4 then first else String.sub first 0 3 105 105 - | [] -> h) 118 118 + match String.split_on_char '.' h with 119 119 + | first :: _ -> 120 120 + if String.length first <= 4 then first 121 121 + else String.sub first 0 3 122 122 + | [] -> h) 106 123 | Error _ -> "local" 107 124 in 108 125 Fmt.pr "%a %a\n" 109 109 - Fmt.(styled `Bold string) "Unregistered:" 110 110 - Fmt.(styled `Faint int) (List.length unregistered); 111 111 - List.iter (fun (_r, p) -> 112 112 - Fmt.pr " %-22s %a\n" p Fmt.(styled `Faint (fun ppf s -> pf ppf "%s~" s)) handle_abbrev) 126 126 + Fmt.(styled `Bold string) 127 127 + "Unregistered:" 128 128 + Fmt.(styled `Faint int) 129 129 + (List.length unregistered); 130 130 + List.iter 131 131 + (fun (_r, p) -> 132 132 + Fmt.pr " %-22s %a\n" p 133 133 + Fmt.(styled `Faint (fun ppf s -> pf ppf "%s~" s)) 134 134 + handle_abbrev) 113 135 unregistered 114 136 end 115 137 | Error _ -> ()); ··· 118 140 | Error _ -> () 119 141 | Ok verse_config -> 120 142 let forks = 121 121 - Monopam.Forks.compute ~proc ~fs ~verse_config ~monopam_config:config () 143 143 + Monopam.Forks.compute ~proc ~fs ~verse_config 144 144 + ~monopam_config:config () 122 145 in 123 146 if forks.repos <> [] then 124 147 Fmt.pr "%a" (Monopam.Forks.pp_summary' ~show_all) forks); ··· 160 183 `S "PHASES"; 161 184 `P "The sync command executes these phases in order:"; 162 185 `I ("1. Validate", "Abort if the monorepo has uncommitted changes"); 163 163 - `I ("2. Push", "Export monorepo changes to checkouts (parallel) [--skip-push skips]"); 186 186 + `I 187 187 + ( "2. Push", 188 188 + "Export monorepo changes to checkouts (parallel) [--skip-push skips]" 189 189 + ); 164 190 `I ("3. Fetch", "Clone/fetch from remotes (parallel) [--skip-pull skips]"); 165 191 `I ("4. Merge", "Fast-forward merge checkouts [--skip-pull skips]"); 166 192 `I ("5. Subtree", "Pull subtrees into monorepo [--skip-pull skips]"); 167 193 `I ("6. Finalize", "Update README.md, CLAUDE.md, and dune-project"); 168 194 `I ("7. Remote", "Push to upstream remotes if --remote (parallel)"); 169 195 `S "SKIP OPTIONS"; 170 170 - `I ("--skip-push", "Skip exporting monorepo changes to checkouts. Use when \ 171 171 - you know you have no local changes to export."); 172 172 - `I ("--skip-pull", "Skip fetching and pulling from remotes. Use when you \ 173 173 - only want to export local changes without pulling remote updates."); 196 196 + `I 197 197 + ( "--skip-push", 198 198 + "Skip exporting monorepo changes to checkouts. Use when you know you \ 199 199 + have no local changes to export." ); 200 200 + `I 201 201 + ( "--skip-pull", 202 202 + "Skip fetching and pulling from remotes. Use when you only want to \ 203 203 + export local changes without pulling remote updates." ); 174 204 `S "PREREQUISITES"; 175 205 `P "Before running sync:"; 176 176 - `I ("-", "Commit all changes in the monorepo: $(b,git add -A && git commit)"); 206 206 + `I 207 207 + ( "-", 208 208 + "Commit all changes in the monorepo: $(b,git add -A && git commit)" ); 177 209 `I ("-", "For --remote: ensure git credentials/SSH keys are configured"); 178 210 ] 179 211 in ··· 197 229 with_config env @@ fun config -> 198 230 let fs = Eio.Stdenv.fs env in 199 231 let proc = Eio.Stdenv.process_mgr env in 200 200 - match Monopam.sync ~proc ~fs ~config ?package ~remote ~skip_push ~skip_pull () with 232 232 + match 233 233 + Monopam.sync ~proc ~fs ~config ?package ~remote ~skip_push ~skip_pull () 234 234 + with 201 235 | Ok summary -> 202 202 - if summary.errors = [] then 203 203 - `Ok () 236 236 + if summary.errors = [] then `Ok () 204 237 else begin 205 205 - Fmt.epr "Sync completed with %d errors.@." (List.length summary.errors); 238 238 + Fmt.epr "Sync completed with %d errors.@." 239 239 + (List.length summary.errors); 206 240 `Ok () 207 241 end 208 242 | Error e -> ··· 210 244 `Error (false, "sync failed") 211 245 in 212 246 Cmd.v info 213 213 - Term.(ret (const run $ package_arg $ remote_arg $ skip_push_arg $ skip_pull_arg $ logging_term)) 247 247 + Term.( 248 248 + ret 249 249 + (const run $ package_arg $ remote_arg $ skip_push_arg $ skip_pull_arg 250 250 + $ logging_term)) 214 251 215 252 (* Changes command *) 216 253 ··· 223 260 `P 224 261 "By default, generates weekly entries. Use --daily to generate daily \ 225 262 entries instead."; 226 226 - `P 227 227 - "Changes are stored in the .changes directory at the monorepo root:"; 263 263 + `P "Changes are stored in the .changes directory at the monorepo root:"; 228 264 `I (".changes/<repo>.json", "Weekly changelog entries"); 229 265 `I (".changes/<repo>-daily.json", "Daily changelog entries"); 230 230 - `I (".changes/YYYYMMDD.json", "Aggregated daily entries (default with --daily)"); 231 231 - `P 232 232 - "Also generates aggregated markdown files at the monorepo root:"; 266 266 + `I 267 267 + ( ".changes/YYYYMMDD.json", 268 268 + "Aggregated daily entries (default with --daily)" ); 269 269 + `P "Also generates aggregated markdown files at the monorepo root:"; 233 270 `I ("CHANGES.md", "Aggregated weekly changelog"); 234 271 `I ("DAILY-CHANGES.md", "Aggregated daily changelog"); 235 272 `P "Each entry includes:"; ··· 245 282 (empty summary and changes) rather than 'no changes' text."; 246 283 `P 247 284 "When using --daily, an aggregated JSON file is generated by default \ 248 248 - for the poe Zulip bot broadcasting system. Use --no-aggregate to skip."; 285 285 + for the poe Zulip bot broadcasting system. Use --no-aggregate to \ 286 286 + skip."; 249 287 `P 250 288 "If a per-repo-per-day JSON file already exists for a past day, that \ 251 289 repo is skipped for that day to avoid redundant Claude API calls."; ··· 257 295 Arg.(value & flag & info [ "daily"; "d" ] ~doc) 258 296 in 259 297 let weeks = 260 260 - let doc = "Number of past weeks to analyze (default: 1, current week only). Ignored if --daily is set." in 298 298 + let doc = 299 299 + "Number of past weeks to analyze (default: 1, current week only). \ 300 300 + Ignored if --daily is set." 301 301 + in 261 302 Arg.(value & opt int 1 & info [ "w"; "weeks" ] ~doc) 262 303 in 263 304 let days = 264 264 - let doc = "Number of past days to analyze when using --daily (default: 1, today only)" in 305 305 + let doc = 306 306 + "Number of past days to analyze when using --daily (default: 1, today \ 307 307 + only)" 308 308 + in 265 309 Arg.(value & opt int 1 & info [ "days" ] ~doc) 266 310 in 267 311 let history = 268 268 - let doc = "Number of recent entries to include in aggregated markdown (default: 12 for weekly, 30 for daily)" in 312 312 + let doc = 313 313 + "Number of recent entries to include in aggregated markdown (default: 12 \ 314 314 + for weekly, 30 for daily)" 315 315 + in 269 316 Arg.(value & opt int 12 & info [ "history" ] ~doc) 270 317 in 271 318 let dry_run = ··· 273 320 Arg.(value & flag & info [ "dry-run"; "n" ] ~doc) 274 321 in 275 322 let no_aggregate = 276 276 - let doc = "Skip generating .changes/YYYYMMDD.json aggregated file (--daily generates it by default)" in 323 323 + let doc = 324 324 + "Skip generating .changes/YYYYMMDD.json aggregated file (--daily \ 325 325 + generates it by default)" 326 326 + in 277 327 Arg.(value & flag & info [ "no-aggregate" ] ~doc) 278 328 in 279 329 let run package daily weeks days history dry_run no_aggregate () = ··· 288 338 let history = if history = 12 then 30 else history in 289 339 (* Aggregate by default for daily, unless --no-aggregate is passed *) 290 340 let aggregate = not no_aggregate in 291 291 - Monopam.changes_daily ~proc ~fs ~config ~clock ?package ~days ~history ~dry_run ~aggregate () 341 341 + Monopam.changes_daily ~proc ~fs ~config ~clock ?package ~days ~history 342 342 + ~dry_run ~aggregate () 292 343 end 293 344 else 294 294 - Monopam.changes ~proc ~fs ~config ~clock ?package ~weeks ~history ~dry_run () 345 345 + Monopam.changes ~proc ~fs ~config ~clock ?package ~weeks ~history 346 346 + ~dry_run () 295 347 in 296 348 match result with 297 349 | Ok () -> ··· 318 370 `S Manpage.s_description; 319 371 `P 320 372 "Copies .opam files from monorepo subtrees to the opam-repo overlay. \ 321 321 - This ensures your opam overlay reflects any changes you made to \ 322 322 - .opam files in the monorepo."; 373 373 + This ensures your opam overlay reflects any changes you made to .opam \ 374 374 + files in the monorepo."; 323 375 `S "HOW IT WORKS"; 324 376 `P "For each package in your opam overlay:"; 325 325 - `I ("1.", "Reads the .opam file from the monorepo subtree (e.g., mono/eio/eio.opam)"); 326 326 - `I ("2.", "Compares with the opam-repo version (e.g., opam-repo/packages/eio/eio.dev/opam)"); 377 377 + `I 378 378 + ( "1.", 379 379 + "Reads the .opam file from the monorepo subtree (e.g., \ 380 380 + mono/eio/eio.opam)" ); 381 381 + `I 382 382 + ( "2.", 383 383 + "Compares with the opam-repo version (e.g., \ 384 384 + opam-repo/packages/eio/eio.dev/opam)" ); 327 385 `I ("3.", "If different, copies monorepo → opam-repo"); 328 386 `I ("4.", "Stages and commits changes in opam-repo"); 329 387 `S "PRECEDENCE"; ··· 343 401 let proc = Eio.Stdenv.process_mgr env in 344 402 match Monopam.sync_opam_files ~proc ~fs ~config ?package () with 345 403 | Ok result -> 346 346 - if result.synced = [] then 347 347 - Fmt.pr "All opam files already in sync.@." 348 348 - else 349 349 - Fmt.pr "Synced %d opam files.@." (List.length result.synced); 404 404 + if result.synced = [] then Fmt.pr "All opam files already in sync.@." 405 405 + else Fmt.pr "Synced %d opam files.@." (List.length result.synced); 350 406 `Ok () 351 407 | Error e -> 352 408 Fmt.epr "Error: %a@." Monopam.pp_error_with_hint e; ··· 369 425 let info = Cmd.info "opam" ~doc ~man in 370 426 Cmd.group info [ opam_sync_cmd ] 371 427 372 372 - (* Verse commands *) 428 428 + (* Init command - initialize a new monopam workspace *) 373 429 374 374 - (* Helper to load verse config from XDG *) 375 375 - let with_verse_config env f = 376 376 - let fs = Eio.Stdenv.fs env in 377 377 - match Monopam.Verse_config.load ~fs () with 378 378 - | Ok config -> f config 379 379 - | Error msg -> 380 380 - Fmt.epr "Error loading opamverse config: %s@." msg; 381 381 - Fmt.epr "Run 'monopam verse init' to create a workspace.@."; 382 382 - `Error (false, "configuration error") 383 383 - 384 384 - let verse_root_arg = 385 385 - let doc = "Path to workspace root directory. Defaults to current directory." in 430 430 + let init_root_arg = 431 431 + let doc = 432 432 + "Path to workspace root directory. Defaults to current directory." 433 433 + in 386 434 Arg.( 387 435 value 388 436 & opt (some (conv (Fpath.of_string, Fpath.pp))) None 389 437 & info [ "root" ] ~docv:"PATH" ~doc) 390 438 391 391 - let verse_handle_arg = 392 392 - let doc = "Tangled handle (e.g., alice.bsky.social)" in 393 393 - Arg.(required & opt (some string) None & info [ "handle" ] ~docv:"HANDLE" ~doc) 394 394 - 395 395 - let verse_handle_opt_pos_arg = 396 396 - let doc = "Tangled handle. If not specified, operates on all tracked members." in 397 397 - Arg.(value & pos 0 (some string) None & info [] ~docv:"HANDLE" ~doc) 439 439 + let init_handle_arg = 440 440 + let doc = "Your handle (e.g., alice.bsky.social)" in 441 441 + Arg.( 442 442 + required & opt (some string) None & info [ "handle" ] ~docv:"HANDLE" ~doc) 398 443 399 399 - let verse_init_cmd = 400 400 - let doc = "Initialize a new opamverse workspace" in 444 444 + let init_cmd = 445 445 + let doc = "Initialize a new monopam workspace" in 401 446 let man = 402 447 [ 403 448 `S Manpage.s_description; 404 449 `P 405 405 - "Creates a new opamverse workspace for federated monorepo collaboration. \ 406 406 - An opamverse workspace lets you browse and track other developers' \ 407 407 - monorepos alongside your own."; 450 450 + "Creates a new monopam workspace for monorepo development. The workspace \ 451 451 + lets you manage your own monorepo and optionally browse and track other \ 452 452 + developers' monorepos."; 408 453 `S "WORKSPACE STRUCTURE"; 409 409 - `P "The init command creates the following directory structure at the workspace root:"; 454 454 + `P 455 455 + "The init command creates the following directory structure at the \ 456 456 + workspace root:"; 410 457 `I ("mono/", "Your monorepo - use with standard monopam commands"); 411 458 `I ("src/", "Your source checkouts - individual git repos"); 412 459 `I ("verse/", "Other users' monorepos, organized by handle"); 413 460 `P "Configuration and data are stored in XDG directories:"; 414 461 `I ("~/.config/monopam/opamverse.toml", "Workspace configuration"); 415 415 - `I ("~/.local/share/monopam/opamverse-registry/", "Git clone of the community registry"); 462 462 + `I 463 463 + ( "~/.local/share/monopam/opamverse-registry/", 464 464 + "Git clone of the community registry" ); 416 465 `S "CONFIGURATION FILE"; 417 466 `P "The opamverse.toml file has the following structure:"; 418 418 - `Pre "[workspace]\n\ 419 419 - root = \"/path/to/workspace\"\n\ 420 420 - default_branch = \"main\"\n\n\ 421 421 - [paths]\n\ 422 422 - mono = \"mono\"\n\ 423 423 - src = \"src\"\n\ 424 424 - verse = \"verse\"\n\n\ 425 425 - [identity]\n\ 426 426 - handle = \"yourname.bsky.social\""; 427 427 - `S "AUTHENTICATION"; 428 428 - `P 429 429 - "Before running init, you must authenticate with the tangled network:"; 430 430 - `Pre "tangled auth login"; 467 467 + `Pre 468 468 + "[workspace]\n\ 469 469 + root = \"/path/to/workspace\"\n\ 470 470 + default_branch = \"main\"\n\n\ 471 471 + [paths]\n\ 472 472 + mono = \"mono\"\n\ 473 473 + src = \"src\"\n\ 474 474 + verse = \"verse\"\n\n\ 475 475 + [identity]\n\ 476 476 + handle = \"yourname.bsky.social\""; 477 477 + `S "HANDLE VALIDATION"; 431 478 `P 432 432 - "The handle you provide is validated against the AT Protocol identity \ 433 433 - system to ensure it exists and you are authenticated."; 479 479 + "The handle you provide identifies you in the community. \ 480 480 + It should be a valid domain name (e.g., yourname.bsky.social or \ 481 481 + your-domain.com)."; 434 482 `S "REGISTRY"; 435 483 `P 436 436 - "The opamverse registry is a git repository containing an opamverse.toml \ 437 437 - file that lists community members and their monorepo URLs. The default \ 484 484 + "The registry is a git repository containing an opamverse.toml file \ 485 485 + that lists community members and their monorepo URLs. The default \ 438 486 registry is at: https://tangled.org/eeg.cl.cam.ac.uk/opamverse"; 439 487 `S Manpage.s_examples; 440 440 - `P "Initialize a workspace in ~/tangled:"; 441 441 - `Pre "cd ~/tangled\n\ 442 442 - monopam verse init --handle alice.bsky.social"; 488 488 + `P "Initialize a workspace in the current directory:"; 489 489 + `Pre "monopam init --handle alice.bsky.social"; 443 490 `P "Initialize with explicit root path:"; 444 444 - `Pre "monopam verse init --root ~/my-workspace --handle alice.bsky.social"; 491 491 + `Pre "monopam init --root ~/my-workspace --handle alice.bsky.social"; 445 492 ] 446 493 in 447 494 let info = Cmd.info "init" ~doc ~man in ··· 452 499 let root = 453 500 match root with 454 501 | Some r -> r 455 455 - | None -> 502 502 + | None -> ( 456 503 let cwd_path = Eio.Stdenv.cwd env in 457 504 let _, cwd_str = (cwd_path :> _ Eio.Path.t) in 458 505 match Fpath.of_string cwd_str with 459 506 | Ok p -> p 460 460 - | Error (`Msg _) -> Fpath.v "." 507 507 + | Error (`Msg _) -> Fpath.v ".") 461 508 in 462 509 match Monopam.Verse.init ~proc ~fs ~root ~handle () with 463 510 | Ok () -> 464 464 - Fmt.pr "Monoverse workspace initialized at %a@." Fpath.pp root; 511 511 + Fmt.pr "Workspace initialized at %a@." Fpath.pp root; 465 512 `Ok () 466 513 | Error e -> 467 514 Fmt.epr "Error: %a@." Monopam.Verse.pp_error_with_hint e; 468 515 `Error (false, "init failed") 469 516 in 470 470 - Cmd.v info Term.(ret (const run $ verse_root_arg $ verse_handle_arg $ logging_term)) 517 517 + Cmd.v info 518 518 + Term.(ret (const run $ init_root_arg $ init_handle_arg $ logging_term)) 519 519 + 520 520 + (* Verse commands *) 521 521 + 522 522 + (* Helper to load verse config from XDG *) 523 523 + let with_verse_config env f = 524 524 + let fs = Eio.Stdenv.fs env in 525 525 + match Monopam.Verse_config.load ~fs () with 526 526 + | Ok config -> f config 527 527 + | Error msg -> 528 528 + Fmt.epr "Error loading opamverse config: %s@." msg; 529 529 + Fmt.epr "Run 'monopam init' to create a workspace.@."; 530 530 + `Error (false, "configuration error") 471 531 472 532 let verse_members_cmd = 473 533 let doc = "List registry members" in ··· 476 536 `S Manpage.s_description; 477 537 `P 478 538 "Lists all members registered in the opamverse community registry. \ 479 479 - This shows everyone who has published their monorepo for collaboration."; 539 539 + This shows everyone who has published their monorepo for \ 540 540 + collaboration."; 480 541 `P 481 542 "The registry is automatically pulled (git pull) when running this \ 482 543 command to ensure you see the latest members."; ··· 484 545 `P 485 546 "The registry is a git repository containing an opamverse.toml file \ 486 547 with the following structure:"; 487 487 - `Pre "[registry]\n\ 488 488 - name = \"tangled-community\"\n\n\ 489 489 - [[members]]\n\ 490 490 - handle = \"alice.bsky.social\"\n\ 491 491 - monorepo = \"https://github.com/alice/mono\"\n\n\ 492 492 - [[members]]\n\ 493 493 - handle = \"bob.example.com\"\n\ 494 494 - monorepo = \"https://github.com/bob/mono\""; 548 548 + `Pre 549 549 + "[registry]\n\ 550 550 + name = \"tangled-community\"\n\n\ 551 551 + [[members]]\n\ 552 552 + handle = \"alice.bsky.social\"\n\ 553 553 + monorepo = \"https://github.com/alice/mono\"\n\n\ 554 554 + [[members]]\n\ 555 555 + handle = \"bob.example.com\"\n\ 556 556 + monorepo = \"https://github.com/bob/mono\""; 495 557 `S "OUTPUT"; 496 558 `P "Each line shows a member's handle and their monorepo git URL:"; 497 497 - `Pre "alice.bsky.social -> https://github.com/alice/mono\n\ 498 498 - bob.example.com -> https://github.com/bob/mono"; 559 559 + `Pre 560 560 + "alice.bsky.social -> https://github.com/alice/mono\n\ 561 561 + bob.example.com -> https://github.com/bob/mono"; 499 562 `S "ADDING YOURSELF"; 500 563 `P 501 564 "To add yourself to the registry, submit a pull request to the \ ··· 520 583 in 521 584 Cmd.v info Term.(ret (const run $ logging_term)) 522 585 523 523 - let verse_pull_cmd = 524 524 - let doc = "Sync all registry members to local workspace" in 525 525 - let man = 526 526 - [ 527 527 - `S Manpage.s_description; 528 528 - `P 529 529 - "Clones or pulls all members from the opamverse registry. For each \ 530 530 - member, syncs both their monorepo and opam overlay repository."; 531 531 - `S "WHAT IT DOES"; 532 532 - `P "For each member in the registry:"; 533 533 - `I ("1.", "Clones or pulls their monorepo to verse/<handle>/"); 534 534 - `I ("2.", "Clones or pulls their opam repo to verse/<handle>-opam/"); 535 535 - `S "SCOPE"; 536 536 - `P "With a handle argument: syncs only that specific member."; 537 537 - `P "Without arguments: syncs all members in the registry."; 538 538 - `S "ERROR HANDLING"; 539 539 - `P 540 540 - "If a sync fails for one member (e.g., network error), the error \ 541 541 - is reported but other members are still synced."; 542 542 - `S Manpage.s_examples; 543 543 - `Pre "# Sync all registry members\n\ 544 544 - monopam verse pull\n\n\ 545 545 - # Sync a specific member\n\ 546 546 - monopam verse pull alice.bsky.social\n\n\ 547 547 - # Browse their code\n\ 548 548 - ls verse/alice.bsky.social/"; 549 549 - ] 550 550 - in 551 551 - let info = Cmd.info "pull" ~doc ~man in 552 552 - let run handle () = 553 553 - Eio_main.run @@ fun env -> 554 554 - with_verse_config env @@ fun config -> 555 555 - let fs = Eio.Stdenv.fs env in 556 556 - let proc = Eio.Stdenv.process_mgr env in 557 557 - match Monopam.Verse.pull ~proc ~fs ~config ?handle () with 558 558 - | Ok () -> 559 559 - Fmt.pr "Sync completed.@."; 560 560 - `Ok () 561 561 - | Error e -> 562 562 - Fmt.epr "Error: %a@." Monopam.Verse.pp_error_with_hint e; 563 563 - `Error (false, "pull failed") 564 564 - in 565 565 - Cmd.v info Term.(ret (const run $ verse_handle_opt_pos_arg $ logging_term)) 566 566 - 567 567 - let verse_sync_cmd = 568 568 - let doc = "Sync the workspace" in 569 569 - let man = 570 570 - [ 571 571 - `S Manpage.s_description; 572 572 - `P 573 573 - "Synchronizes your entire opamverse workspace with the latest upstream \ 574 574 - changes. This is the command to run regularly to stay up to date."; 575 575 - `S "WHAT IT DOES"; 576 576 - `P "The sync command performs two operations:"; 577 577 - `I ("1.", "Updates the registry: git pull in ~/.local/share/monopam/opamverse-registry/"); 578 578 - `I ("2.", "Pulls all tracked members: git pull in each verse/<handle>/"); 579 579 - `S "USE CASES"; 580 580 - `P "Run sync when you want to:"; 581 581 - `I ("-", "See if any new members have joined the community"); 582 582 - `I ("-", "Get the latest code from all tracked members"); 583 583 - `I ("-", "Catch up after being away for a while"); 584 584 - `S "COMPARISON WITH PULL"; 585 585 - `P 586 586 - "'verse sync' updates the registry AND pulls members. \ 587 587 - 'verse pull' only pulls members (skips registry update)."; 588 588 - `S Manpage.s_examples; 589 589 - `Pre "# Daily sync routine\n\ 590 590 - cd ~/tangled\n\ 591 591 - monopam verse sync\n\ 592 592 - monopam verse status"; 593 593 - ] 594 594 - in 595 595 - let info = Cmd.info "sync" ~doc ~man in 596 596 - let run () = 597 597 - Eio_main.run @@ fun env -> 598 598 - with_verse_config env @@ fun config -> 599 599 - let fs = Eio.Stdenv.fs env in 600 600 - let proc = Eio.Stdenv.process_mgr env in 601 601 - match Monopam.Verse.sync ~proc ~fs ~config () with 602 602 - | Ok () -> 603 603 - Fmt.pr "Sync completed.@."; 604 604 - `Ok () 605 605 - | Error e -> 606 606 - Fmt.epr "Error: %a@." Monopam.Verse.pp_error_with_hint e; 607 607 - `Error (false, "sync failed") 608 608 - in 609 609 - Cmd.v info Term.(ret (const run $ logging_term)) 610 610 - 611 586 let verse_fork_cmd = 612 587 let doc = "Fork a package from a verse member's repository" in 613 588 let man = ··· 682 657 (List.length result.packages_forked) result.source_handle; 683 658 List.iter (fun p -> Fmt.pr " %s@." p) result.packages_forked 684 659 end else begin 660 660 + (* Update sources.toml with fork information *) 661 661 + let mono_path = Monopam.Verse_config.mono_path config in 662 662 + let sources_path = Fpath.(mono_path / "sources.toml") in 663 663 + let sources = 664 664 + match Monopam.Sources_registry.load ~fs:(fs :> _ Eio.Path.t) sources_path with 665 665 + | Ok s -> s 666 666 + | Error _ -> Monopam.Sources_registry.empty 667 667 + in 668 668 + let entry = Monopam.Sources_registry.{ 669 669 + url = result.fork_url; 670 670 + upstream = Some result.upstream_url; 671 671 + branch = None; 672 672 + reason = Some (Fmt.str "Forked from %s" result.source_handle); 673 673 + origin = Some Join; (* Forked from verse = joined *) 674 674 + } in 675 675 + let sources = Monopam.Sources_registry.add sources ~subtree:result.subtree_name entry in 676 676 + (match Monopam.Sources_registry.save ~fs:(fs :> _ Eio.Path.t) sources_path sources with 677 677 + | Ok () -> 678 678 + Fmt.pr "Updated sources.toml with fork entry for %s@." result.subtree_name 679 679 + | Error msg -> 680 680 + Fmt.epr "Warning: Failed to update sources.toml: %s@." msg); 685 681 Fmt.pr "Forked %d package(s): %a@." 686 682 (List.length result.packages_forked) 687 683 Fmt.(list ~sep:(any ", ") string) result.packages_forked; ··· 697 693 Cmd.v info Term.(ret (const run $ package_arg $ from_arg $ url_arg $ dry_run_arg $ logging_term)) 698 694 699 695 let verse_cmd = 700 700 - let doc = "Federated monorepo collaboration" in 696 696 + let doc = "Verse member operations" in 701 697 let man = 702 698 [ 703 699 `S Manpage.s_description; 704 700 `P 705 705 - "The opamverse system enables federated collaboration across multiple \ 706 706 - developers' monorepos. Each developer maintains their own monorepo \ 707 707 - (managed by standard monopam commands), and can track other developers' \ 708 708 - monorepos for code browsing, learning, and collaboration."; 709 709 - `P 710 710 - "Members are identified by tangled handles - decentralized identities \ 711 711 - from the AT Protocol network (the same system used by Bluesky)."; 712 712 - `S "QUICK START FOR NEW USERS"; 713 713 - `P "Run these commands in order to get started:"; 714 714 - `Pre "# Step 1: Authenticate with tangled (one-time setup)\n\ 715 715 - tangled auth login\n\n\ 716 716 - # Step 2: Create and initialize your workspace\n\ 717 717 - mkdir ~/tangled && cd ~/tangled\n\ 718 718 - monopam verse init --handle yourname.bsky.social\n\n\ 719 719 - # Step 3: Sync all community members\n\ 720 720 - monopam verse pull\n\n\ 721 721 - # Step 4: Browse their code\n\ 722 722 - ls verse/\n\ 723 723 - cd verse/alice.bsky.social && dune build\n\n\ 724 724 - # Step 5: Keep everything updated (run daily/weekly)\n\ 725 725 - monopam verse sync"; 726 726 - `S "KEY CONCEPTS"; 727 727 - `I ("Workspace", "A directory containing your monorepo plus all registry members' repos"); 728 728 - `I ("Registry", "A git repository listing community members and their repo URLs"); 729 729 - `I ("Handle", "A tangled identity like 'alice.bsky.social' validated via AT Protocol"); 730 730 - `S "WORKSPACE STRUCTURE"; 731 731 - `P "An opamverse workspace has this layout:"; 732 732 - `Pre "~/tangled/ # workspace root\n\ 733 733 - ├── mono/ # YOUR monorepo\n\ 734 734 - ├── src/ # YOUR fork checkouts\n\ 735 735 - ├── opam-repo/ # YOUR opam overlay\n\ 736 736 - └── verse/\n\ 737 737 - \ ├── alice.bsky.social/ # Alice's monorepo\n\ 738 738 - \ ├── alice.bsky.social-opam/ # Alice's opam overlay\n\ 739 739 - \ ├── bob.example.com/ # Bob's monorepo\n\ 740 740 - \ └── bob.example.com-opam/ # Bob's opam overlay"; 741 741 - `P "Configuration and data are stored in XDG directories:"; 742 742 - `Pre "~/.config/monopam/\n\ 743 743 - └── opamverse.toml # workspace configuration\n\n\ 744 744 - ~/.local/share/monopam/\n\ 745 745 - └── opamverse-registry/ # cloned registry git repo"; 746 746 - `S "COMMAND FLOW"; 747 747 - `P "The expected sequence of commands for typical workflows:"; 748 748 - `P "$(b,First-time setup) (once per machine):"; 749 749 - `Pre "tangled auth login # authenticate\n\ 750 750 - monopam verse init --handle you.bsky.social # create workspace"; 751 751 - `P "$(b,Syncing all members):"; 752 752 - `Pre "monopam verse pull # clone/pull all members\n\ 753 753 - monopam verse status # check status"; 754 754 - `P "$(b,Daily maintenance):"; 755 755 - `Pre "monopam verse sync # update everything\n\ 756 756 - monopam verse status # check for changes"; 757 757 - `P "$(b,Working in your own monorepo):"; 758 758 - `Pre "cd ~/tangled/mono\n\ 759 759 - monopam pull # fetch upstream changes\n\ 760 760 - # ... make edits ...\n\ 761 761 - monopam push # export to checkouts"; 762 762 - `S "INTEGRATION WITH MONOPAM"; 763 763 - `P 764 764 - "The verse system complements standard monopam commands. Your mono/ \ 765 765 - directory works exactly like a normal monopam-managed monorepo:"; 766 766 - `Pre "# Work in your monorepo\n\ 767 767 - cd ~/tangled/mono\n\ 768 768 - monopam status\n\ 769 769 - monopam pull\n\ 770 770 - # ... make changes ...\n\ 771 771 - monopam push"; 701 701 + "Commands for working with verse community members. The verse system \ 702 702 + enables federated collaboration across multiple developers' monorepos."; 772 703 `P 773 773 - "The verse/ directories are for reading and learning from others' code. \ 774 774 - You generally don't push to them (unless you're a collaborator)."; 775 775 - `S "REGISTRY FORMAT"; 776 776 - `P 777 777 - "The registry is a git repository containing opamverse.toml:"; 778 778 - `Pre "[registry]\n\ 779 779 - name = \"tangled-community\"\n\n\ 780 780 - [[members]]\n\ 781 781 - handle = \"alice.bsky.social\"\n\ 782 782 - monorepo = \"https://github.com/alice/mono\""; 704 704 + "Members are identified by handles - typically domain names like \ 705 705 + 'yourname.bsky.social' or 'your-domain.com'."; 706 706 + `S "NOTE"; 783 707 `P 784 784 - "Default registry: https://tangled.org/eeg.cl.cam.ac.uk/opamverse"; 785 785 - `S "COMMANDS REFERENCE"; 786 786 - `I ("init", "Create a new workspace with config and directories"); 787 787 - `I ("status", "Show members and their git status"); 788 788 - `I ("members", "List all members in the registry"); 789 789 - `I ("pull [<handle>]", "Clone/pull all members (or specific member)"); 790 790 - `I ("sync", "Update registry and pull all members"); 708 708 + "The $(b,monopam init) command creates your workspace and \ 709 709 + $(b,monopam sync) automatically syncs verse members. These commands \ 710 710 + are for additional verse-specific operations."; 711 711 + `S "COMMANDS"; 712 712 + `I ("members", "List all members in the community registry"); 791 713 `I ("fork <pkg> --from <handle> --url <url>", "Fork a package from a verse member"); 792 792 - `S "AUTHENTICATION"; 793 793 - `P 794 794 - "Handle validation uses the AT Protocol identity system. The tangled \ 795 795 - CLI stores session credentials that monopam verse commands reuse."; 796 796 - `P "If you see 'Not authenticated', run:"; 797 797 - `Pre "tangled auth login"; 714 714 + `S Manpage.s_examples; 715 715 + `P "List all community members:"; 716 716 + `Pre "monopam verse members"; 717 717 + `P "Fork a package from another member:"; 718 718 + `Pre "monopam verse fork cohttp --from avsm.bsky.social --url git@github.com:me/cohttp.git"; 798 719 ] 799 720 in 800 721 let info = Cmd.info "verse" ~doc ~man in 801 722 Cmd.group info 802 723 [ 803 803 - verse_init_cmd; 804 724 verse_members_cmd; 805 805 - verse_pull_cmd; 806 806 - verse_sync_cmd; 807 725 verse_fork_cmd; 808 726 ] 809 727 728 728 + (* Diff command *) 729 729 + 730 730 + let diff_cmd = 731 731 + let doc = "Show diffs from verse members for repos needing attention" in 732 732 + let man = 733 733 + [ 734 734 + `S Manpage.s_description; 735 735 + `P 736 736 + "Shows commit diffs from verse members for repositories where they have \ 737 737 + commits you don't have. This helps you see what changes are available \ 738 738 + from collaborators."; 739 739 + `S "OUTPUT"; 740 740 + `P "First shows the verse status summary, then for each repository where \ 741 741 + a verse member is ahead:"; 742 742 + `I ("Repository name", "With the handle and relationship"); 743 743 + `I ("Commits", "List of commits they have that you don't (max 20)"); 744 744 + `S "RELATIONSHIPS"; 745 745 + `I ("+N", "They have N commits you don't have"); 746 746 + `I ("+N/-M", "Diverged: they have N new commits, you have M new commits"); 747 747 + `S "CACHING"; 748 748 + `P "Remote fetches are cached for 1 hour to improve performance. \ 749 749 + Use $(b,--refresh) to force fresh fetches from all remotes."; 750 750 + `S Manpage.s_examples; 751 751 + `P "Show diffs for all repos needing attention (uses cache):"; 752 752 + `Pre "monopam diff"; 753 753 + `P "Show diff for a specific repository:"; 754 754 + `Pre "monopam diff ocaml-eio"; 755 755 + `P "Show patches for all commits:"; 756 756 + `Pre "monopam diff -p"; 757 757 + `P "Show patch for a specific commit (from diff output):"; 758 758 + `Pre "monopam diff abc1234"; 759 759 + `P "Force fresh fetches from all remotes:"; 760 760 + `Pre "monopam diff --refresh"; 761 761 + ] 762 762 + in 763 763 + let info = Cmd.info "diff" ~doc ~man in 764 764 + let arg = 765 765 + let doc = "Repository name or commit SHA. If a 7+ character hex string, shows \ 766 766 + the patch for that commit. Otherwise filters to that repository. \ 767 767 + If not specified, shows diffs for all repos needing attention." in 768 768 + Arg.(value & pos 0 (some string) None & info [] ~docv:"REPO|SHA" ~doc) 769 769 + in 770 770 + let refresh_arg = 771 771 + let doc = "Force fresh fetches from all remotes, ignoring the 1-hour cache." in 772 772 + Arg.(value & flag & info [ "refresh"; "r" ] ~doc) 773 773 + in 774 774 + let patch_arg = 775 775 + let doc = "Show full patch content for each commit." in 776 776 + Arg.(value & flag & info [ "patch"; "p" ] ~doc) 777 777 + in 778 778 + let run arg refresh patch () = 779 779 + Eio_main.run @@ fun env -> 780 780 + with_config env @@ fun config -> 781 781 + with_verse_config env @@ fun verse_config -> 782 782 + let fs = Eio.Stdenv.fs env in 783 783 + let proc = Eio.Stdenv.process_mgr env in 784 784 + (* Check if arg looks like a commit SHA *) 785 785 + match arg with 786 786 + | Some sha when Monopam.is_commit_sha sha -> 787 787 + (* Show patch for specific commit *) 788 788 + (match Monopam.diff_show_commit ~proc ~fs ~config ~verse_config ~sha ~refresh () with 789 789 + | Some info -> 790 790 + let short_hash = String.sub info.commit_hash 0 (min 7 (String.length info.commit_hash)) in 791 791 + Fmt.pr "%a %s (%s/%s)@.@.%s@." 792 792 + Fmt.(styled `Yellow string) short_hash 793 793 + info.commit_subject 794 794 + info.commit_repo info.commit_handle 795 795 + info.commit_patch; 796 796 + `Ok () 797 797 + | None -> 798 798 + Fmt.epr "Commit %s not found in any verse diff@." sha; 799 799 + `Error (false, "commit not found")) 800 800 + | repo -> 801 801 + let result = Monopam.diff ~proc ~fs ~config ~verse_config ?repo ~refresh ~patch () in 802 802 + Fmt.pr "%a" (Monopam.pp_diff_result ~show_patch:patch) result; 803 803 + `Ok () 804 804 + in 805 805 + Cmd.v info Term.(ret (const run $ arg $ refresh_arg $ patch_arg $ logging_term)) 806 806 + 807 807 + (* Pull command - pull from verse members *) 808 808 + 809 809 + let pull_cmd = 810 810 + let doc = "Pull commits from a verse member's forks" in 811 811 + let man = 812 812 + [ 813 813 + `S Manpage.s_description; 814 814 + `P 815 815 + "Pulls commits from a verse member's forks into your local checkouts. \ 816 816 + This merges their changes into your checkout branches, making them \ 817 817 + ready to be synced to the monorepo via $(b,monopam sync)."; 818 818 + `S "WORKFLOW"; 819 819 + `P "The typical workflow for incorporating changes from collaborators:"; 820 820 + `I ("1.", "$(b,monopam diff) - See what changes are available"); 821 821 + `I ("2.", "$(b,monopam pull <handle>) - Pull changes from a collaborator"); 822 822 + `I ("3.", "$(b,monopam sync) - Sync changes into your monorepo"); 823 823 + `S "MERGING BEHAVIOR"; 824 824 + `P "When you're behind (they have commits you don't):"; 825 825 + `I ("Fast-forward", "If your branch has no new commits, a fast-forward merge is used."); 826 826 + `P "When branches have diverged (both have new commits):"; 827 827 + `I ("Merge commit", "A merge commit is created to combine the histories."); 828 828 + `S Manpage.s_examples; 829 829 + `P "Pull all changes from a verse member:"; 830 830 + `Pre "monopam pull avsm.bsky.social"; 831 831 + `P "Pull changes for a specific repository:"; 832 832 + `Pre "monopam pull avsm.bsky.social eio"; 833 833 + `P "Force fresh fetches before pulling:"; 834 834 + `Pre "monopam pull --refresh avsm.bsky.social"; 835 835 + ] 836 836 + in 837 837 + let info = Cmd.info "pull" ~doc ~man in 838 838 + let handle_arg = 839 839 + let doc = "The verse member handle to pull from (e.g., avsm.bsky.social)." in 840 840 + Arg.(required & pos 0 (some string) None & info [] ~docv:"HANDLE" ~doc) 841 841 + in 842 842 + let repo_arg = 843 843 + let doc = "Optional repository to pull from. If not specified, pulls from all \ 844 844 + repositories where the handle has commits you don't have." in 845 845 + Arg.(value & pos 1 (some string) None & info [] ~docv:"REPO" ~doc) 846 846 + in 847 847 + let refresh_arg = 848 848 + let doc = "Force fresh fetches from all remotes, ignoring the 1-hour cache." in 849 849 + Arg.(value & flag & info [ "refresh"; "r" ] ~doc) 850 850 + in 851 851 + let run handle repo refresh () = 852 852 + Eio_main.run @@ fun env -> 853 853 + with_config env @@ fun config -> 854 854 + with_verse_config env @@ fun verse_config -> 855 855 + let fs = Eio.Stdenv.fs env in 856 856 + let proc = Eio.Stdenv.process_mgr env in 857 857 + match Monopam.pull_from_handle ~proc ~fs ~config ~verse_config ~handle ?repo ~refresh () with 858 858 + | Ok result -> 859 859 + Fmt.pr "%a" Monopam.pp_handle_pull_result result; 860 860 + if result.repos_failed <> [] then 861 861 + `Error (false, "some repos failed to pull") 862 862 + else if result.repos_pulled = [] then begin 863 863 + Fmt.pr "Nothing to pull from %s@." handle; 864 864 + `Ok () 865 865 + end 866 866 + else begin 867 867 + Fmt.pr "@.Run $(b,monopam sync) to merge changes into your monorepo.@."; 868 868 + `Ok () 869 869 + end 870 870 + | Error e -> 871 871 + Fmt.epr "Error: %a@." Monopam.pp_error_with_hint e; 872 872 + `Error (false, "pull failed") 873 873 + in 874 874 + Cmd.v info Term.(ret (const run $ handle_arg $ repo_arg $ refresh_arg $ logging_term)) 875 875 + 876 876 + (* Cherrypick command *) 877 877 + 878 878 + let cherrypick_cmd = 879 879 + let doc = "Cherry-pick a specific commit from a verse member's fork" in 880 880 + let man = 881 881 + [ 882 882 + `S Manpage.s_description; 883 883 + `P 884 884 + "Applies a specific commit from a verse member's fork to your local checkout. \ 885 885 + Use $(b,monopam diff) to see available commits and their hashes."; 886 886 + `S "WORKFLOW"; 887 887 + `P "The typical workflow for cherry-picking specific commits:"; 888 888 + `I ("1.", "$(b,monopam diff) - See available commits with their hashes"); 889 889 + `I ("2.", "$(b,monopam diff <sha>) - View the full patch for a commit"); 890 890 + `I ("3.", "$(b,monopam cherrypick <sha>) - Apply that commit"); 891 891 + `I ("4.", "$(b,monopam sync) - Sync changes into your monorepo"); 892 892 + `S Manpage.s_examples; 893 893 + `P "Cherry-pick a commit:"; 894 894 + `Pre "monopam cherrypick abc1234"; 895 895 + `P "View a commit's patch first, then cherry-pick:"; 896 896 + `Pre "monopam diff abc1234"; 897 897 + `Pre "monopam cherrypick abc1234"; 898 898 + ] 899 899 + in 900 900 + let info = Cmd.info "cherrypick" ~doc ~man in 901 901 + let sha_arg = 902 902 + let doc = "The commit SHA (or prefix) to cherry-pick. Must be at least 7 characters." in 903 903 + Arg.(required & pos 0 (some string) None & info [] ~docv:"SHA" ~doc) 904 904 + in 905 905 + let refresh_arg = 906 906 + let doc = "Force fresh fetches from all remotes, ignoring the 1-hour cache." in 907 907 + Arg.(value & flag & info [ "refresh"; "r" ] ~doc) 908 908 + in 909 909 + let run sha refresh () = 910 910 + Eio_main.run @@ fun env -> 911 911 + with_config env @@ fun config -> 912 912 + with_verse_config env @@ fun verse_config -> 913 913 + let fs = Eio.Stdenv.fs env in 914 914 + let proc = Eio.Stdenv.process_mgr env in 915 915 + match Monopam.cherrypick ~proc ~fs ~config ~verse_config ~sha ~refresh () with 916 916 + | Ok result -> 917 917 + Fmt.pr "%a" Monopam.pp_cherrypick_result result; 918 918 + Fmt.pr "Run $(b,monopam sync) to merge changes into your monorepo.@."; 919 919 + `Ok () 920 920 + | Error e -> 921 921 + Fmt.epr "Error: %a@." Monopam.pp_error_with_hint e; 922 922 + `Error (false, "cherrypick failed") 923 923 + in 924 924 + Cmd.v info Term.(ret (const run $ sha_arg $ refresh_arg $ logging_term)) 925 925 + 810 926 (* Doctor command *) 811 927 812 928 let doctor_cmd = ··· 815 931 [ 816 932 `S Manpage.s_description; 817 933 `P 818 818 - "Analyzes your workspace health and provides actionable recommendations. \ 819 819 - Uses Claude AI to analyze commits from verse collaborators, categorizing \ 820 820 - them by type, priority, and risk level."; 934 934 + "Analyzes your workspace health and provides actionable \ 935 935 + recommendations. Uses Claude AI to analyze commits from verse \ 936 936 + collaborators, categorizing them by type, priority, and risk level."; 821 937 `S "WHAT IT DOES"; 822 938 `P "The doctor command:"; 823 939 `I ("1.", "Syncs the workspace (unless $(b,--no-sync) is specified)"); ··· 826 942 `I ("4.", "Analyzes fork relationships with verse members"); 827 943 `I ("5.", "Uses Claude to categorize and prioritize their commits"); 828 944 `I ("6.", "Generates actionable recommendations"); 829 829 - `P "The status output from $(b,monopam status) is automatically included \ 830 830 - in the prompt sent to Claude, so Claude doesn't need to run it separately."; 945 945 + `P 946 946 + "The status output from $(b,monopam status) is automatically included \ 947 947 + in the prompt sent to Claude, so Claude doesn't need to run it \ 948 948 + separately."; 831 949 `S "OUTPUT FORMATS"; 832 950 `P "By default, outputs human-readable text with colors."; 833 951 `P "Use $(b,--json) for JSON output suitable for tooling."; ··· 867 985 Fmt.pr "Warning: sync failed: %a@." Monopam.pp_error_with_hint e; 868 986 Fmt.pr "Continuing with analysis...@." 869 987 end; 870 870 - let report = Monopam.Doctor.analyze ~proc ~fs ~config ~verse_config ~clock ?package ~no_sync () in 871 871 - if json then 872 872 - print_endline (Monopam.Doctor.to_json report) 873 873 - else 874 874 - Fmt.pr "%a@." Monopam.Doctor.pp_report report; 988 988 + let report = 989 989 + Monopam.Doctor.analyze ~proc ~fs ~config ~verse_config ~clock ?package 990 990 + ~no_sync () 991 991 + in 992 992 + if json then print_endline (Monopam.Doctor.to_json report) 993 993 + else Fmt.pr "%a@." Monopam.Doctor.pp_report report; 875 994 `Ok () 876 995 in 877 877 - Cmd.v info Term.(ret (const run $ package_arg $ json_arg $ no_sync_arg $ logging_term)) 996 996 + Cmd.v info 997 997 + Term.(ret (const run $ package_arg $ json_arg $ no_sync_arg $ logging_term)) 878 998 879 999 (* Feature commands *) 880 1000 ··· 1038 1158 let info = Cmd.info "feature" ~doc ~man in 1039 1159 Cmd.group info [ feature_add_cmd; feature_remove_cmd; feature_list_cmd ] 1040 1160 1161 1161 + (* Devcontainer command *) 1162 1162 + 1163 1163 + let default_devcontainer_url = 1164 1164 + "https://raw.githubusercontent.com/avsm/claude-ocaml-devcontainer/refs/heads/main/.devcontainer/devcontainer.json" 1165 1165 + 1166 1166 + let devcontainer_cmd = 1167 1167 + let doc = "Setup and enter a devcontainer environment" in 1168 1168 + let man = 1169 1169 + [ 1170 1170 + `S Manpage.s_description; 1171 1171 + `P 1172 1172 + "Creates and enters a devcontainer environment for OCaml development \ 1173 1173 + with monopam and Claude. If the target directory doesn't have a \ 1174 1174 + .devcontainer configuration, it will be created automatically."; 1175 1175 + `P 1176 1176 + "This is the recommended way to get started with monopam. The \ 1177 1177 + devcontainer provides a consistent environment with OCaml, opam, \ 1178 1178 + and all required tools pre-installed."; 1179 1179 + `S "WHAT IT DOES"; 1180 1180 + `P "For a new directory (no .devcontainer/):"; 1181 1181 + `I ("1.", "Creates the target directory if needed"); 1182 1182 + `I ("2.", "Creates .devcontainer/ subdirectory"); 1183 1183 + `I ("3.", "Downloads devcontainer.json from the template repository"); 1184 1184 + `I ("4.", "Builds and starts the devcontainer"); 1185 1185 + `I ("5.", "Opens an interactive shell inside the container"); 1186 1186 + `P "For an existing directory with .devcontainer/:"; 1187 1187 + `I ("1.", "Starts the devcontainer if not running"); 1188 1188 + `I ("2.", "Opens an interactive shell inside the container"); 1189 1189 + `S Manpage.s_options; 1190 1190 + `P "Use $(b,--url) to specify a custom devcontainer.json URL if you want \ 1191 1191 + to use a different base configuration."; 1192 1192 + `S Manpage.s_examples; 1193 1193 + `P "Create a new devcontainer workspace:"; 1194 1194 + `Pre "monopam devcontainer ~/my-ocaml-project"; 1195 1195 + `P "Enter an existing devcontainer:"; 1196 1196 + `Pre "monopam devcontainer ~/my-ocaml-project"; 1197 1197 + `P "Use a custom devcontainer.json:"; 1198 1198 + `Pre "monopam devcontainer --url https://example.com/devcontainer.json ~/project"; 1199 1199 + ] 1200 1200 + in 1201 1201 + let info = Cmd.info "devcontainer" ~doc ~man in 1202 1202 + let path_arg = 1203 1203 + let doc = "Target directory for the devcontainer workspace." in 1204 1204 + Arg.(required & pos 0 (some string) None & info [] ~docv:"PATH" ~doc) 1205 1205 + in 1206 1206 + let url_arg = 1207 1207 + let doc = "URL to fetch devcontainer.json from. Defaults to the claude-ocaml-devcontainer template." in 1208 1208 + Arg.(value & opt string default_devcontainer_url & info ["url"] ~docv:"URL" ~doc) 1209 1209 + in 1210 1210 + let run path url () = 1211 1211 + (* Resolve to absolute path *) 1212 1212 + let abs_path = 1213 1213 + if Filename.is_relative path then 1214 1214 + Filename.concat (Sys.getcwd ()) path 1215 1215 + else path 1216 1216 + in 1217 1217 + let devcontainer_dir = Filename.concat abs_path ".devcontainer" in 1218 1218 + let devcontainer_json = Filename.concat devcontainer_dir "devcontainer.json" in 1219 1219 + (* Check if .devcontainer exists *) 1220 1220 + let needs_init = not (Sys.file_exists devcontainer_dir && Sys.is_directory devcontainer_dir) in 1221 1221 + if needs_init then begin 1222 1222 + Fmt.pr "Initializing devcontainer in %s...@." abs_path; 1223 1223 + (* Create directories *) 1224 1224 + (try Unix.mkdir abs_path 0o755 with Unix.Unix_error (Unix.EEXIST, _, _) -> ()); 1225 1225 + (try Unix.mkdir devcontainer_dir 0o755 with Unix.Unix_error (Unix.EEXIST, _, _) -> ()); 1226 1226 + (* Fetch devcontainer.json using curl *) 1227 1227 + Fmt.pr "Fetching devcontainer.json from %s...@." url; 1228 1228 + let curl_cmd = Printf.sprintf "curl -fsSL '%s' -o '%s'" url devcontainer_json in 1229 1229 + let ret = Sys.command curl_cmd in 1230 1230 + if ret <> 0 then begin 1231 1231 + Fmt.epr "Error: Failed to fetch devcontainer.json (curl exit code %d)@." ret; 1232 1232 + exit 1 1233 1233 + end; 1234 1234 + Fmt.pr "Created %s@." devcontainer_json; 1235 1235 + (* Build and start the devcontainer *) 1236 1236 + Fmt.pr "Building devcontainer (this may take a while on first run)...@."; 1237 1237 + let up_cmd = Printf.sprintf "npx @devcontainers/cli up --workspace-folder '%s' --remove-existing-container" abs_path in 1238 1238 + let ret = Sys.command up_cmd in 1239 1239 + if ret <> 0 then begin 1240 1240 + Fmt.epr "Error: Failed to start devcontainer (exit code %d)@." ret; 1241 1241 + exit 1 1242 1242 + end 1243 1243 + end; 1244 1244 + (* Exec into the devcontainer *) 1245 1245 + Fmt.pr "Entering devcontainer...@."; 1246 1246 + let exec_cmd = Printf.sprintf "npx @devcontainers/cli exec --workspace-folder '%s' bash -l" abs_path in 1247 1247 + let ret = Sys.command exec_cmd in 1248 1248 + if ret <> 0 then 1249 1249 + `Error (false, Printf.sprintf "devcontainer exec failed with code %d" ret) 1250 1250 + else 1251 1251 + `Ok () 1252 1252 + in 1253 1253 + Cmd.v info Term.(ret (const run $ path_arg $ url_arg $ logging_term)) 1254 1254 + 1255 1255 + (* Confirmation prompt *) 1256 1256 + let confirm prompt = 1257 1257 + Printf.printf "%s [y/N] %!" prompt; 1258 1258 + match In_channel.(input_line stdin) with 1259 1259 + | Some s -> String.lowercase_ascii (String.trim s) = "y" 1260 1260 + | None -> false 1261 1261 + 1262 1262 + (* Prompt for optional string input *) 1263 1263 + let prompt_string prompt = 1264 1264 + Printf.printf "%s %!" prompt; 1265 1265 + match In_channel.(input_line stdin) with 1266 1266 + | Some s -> 1267 1267 + let s = String.trim s in 1268 1268 + if s = "" then None else Some s 1269 1269 + | None -> None 1270 1270 + 1271 1271 + (* Fork command *) 1272 1272 + 1273 1273 + let fork_cmd = 1274 1274 + let doc = "Fork a monorepo subtree into its own repository" in 1275 1275 + let man = 1276 1276 + [ 1277 1277 + `S Manpage.s_description; 1278 1278 + `P 1279 1279 + "Splits a monorepo subdirectory into its own git repository and \ 1280 1280 + establishes a proper subtree relationship. This creates src/<name>/ \ 1281 1281 + with the extracted history, then re-adds mono/<name>/ as a subtree."; 1282 1282 + `S "FORK MODES"; 1283 1283 + `P "The fork command handles two scenarios:"; 1284 1284 + `I ("Subtree with history", "For subtrees added via $(b,git subtree add) or \ 1285 1285 + $(b,monopam join), the command uses $(b,git subtree split) to extract \ 1286 1286 + the full commit history into the new repository."); 1287 1287 + `I ("Fresh package", "For packages created directly in mono/ without subtree \ 1288 1288 + history, the command copies the files and creates an initial commit. \ 1289 1289 + This is useful for new packages you've developed locally."); 1290 1290 + `S "WHAT IT DOES"; 1291 1291 + `P "The fork command performs a complete workflow in one step:"; 1292 1292 + `I ("1.", "Analyzes mono/<name>/ to detect fork mode"); 1293 1293 + `I ("2.", "Builds an action plan and shows discovery details"); 1294 1294 + `I ("3.", "Prompts for confirmation (use $(b,--yes) to skip)"); 1295 1295 + `I ("4.", "Creates a new git repo at src/<name>/"); 1296 1296 + `I ("5.", "Extracts history (subtree split) or copies files (fresh package)"); 1297 1297 + `I ("6.", "Removes mono/<name>/ from git and commits"); 1298 1298 + `I ("7.", "Re-adds mono/<name>/ as a proper subtree from src/<name>/"); 1299 1299 + `I ("8.", "Updates sources.toml with $(b,origin = \"fork\")"); 1300 1300 + `S "AFTER FORKING"; 1301 1301 + `P "After forking, the subtree relationship is fully established:"; 1302 1302 + `I ("-", "mono/<name>/ is now a proper git subtree of src/<name>/"); 1303 1303 + `I ("-", "$(b,monopam sync) will push/pull changes correctly"); 1304 1304 + `I ("-", "No need for manual $(b,git rm) or $(b,monopam rejoin)"); 1305 1305 + `P "To push to a remote:"; 1306 1306 + `Pre "cd src/<name> && git push -u origin main"; 1307 1307 + `S Manpage.s_examples; 1308 1308 + `P "Fork a subtree with local-only repo:"; 1309 1309 + `Pre "monopam fork my-lib"; 1310 1310 + `P "Fork with a remote push URL:"; 1311 1311 + `Pre "monopam fork my-lib git@github.com:me/my-lib.git"; 1312 1312 + `P "Preview what would be done:"; 1313 1313 + `Pre "monopam fork my-lib --dry-run"; 1314 1314 + `P "Fork without confirmation:"; 1315 1315 + `Pre "monopam fork my-lib --yes"; 1316 1316 + ] 1317 1317 + in 1318 1318 + let info = Cmd.info "fork" ~doc ~man in 1319 1319 + let name_arg = 1320 1320 + let doc = "Name of the subtree to fork (directory name under mono/)" in 1321 1321 + Arg.(required & pos 0 (some string) None & info [] ~docv:"NAME" ~doc) 1322 1322 + in 1323 1323 + let url_arg = 1324 1324 + let doc = "Optional remote URL to add as 'origin' for pushing" in 1325 1325 + Arg.(value & pos 1 (some string) None & info [] ~docv:"URL" ~doc) 1326 1326 + in 1327 1327 + let dry_run_arg = 1328 1328 + let doc = "Show what would be done without making changes" in 1329 1329 + Arg.(value & flag & info [ "dry-run"; "n" ] ~doc) 1330 1330 + in 1331 1331 + let yes_arg = 1332 1332 + let doc = "Assume yes to all prompts (for automation)" in 1333 1333 + Arg.(value & flag & info [ "yes"; "y" ] ~doc) 1334 1334 + in 1335 1335 + let run name url dry_run yes () = 1336 1336 + Eio_main.run @@ fun env -> 1337 1337 + with_verse_config env @@ fun config -> 1338 1338 + let fs = Eio.Stdenv.fs env in 1339 1339 + let proc = Eio.Stdenv.process_mgr env in 1340 1340 + (* Get URL: use provided, or try to derive from dune-project, or prompt *) 1341 1341 + let url = 1342 1342 + match url with 1343 1343 + | Some _ -> url 1344 1344 + | None -> 1345 1345 + (* Try to get default from dune-project *) 1346 1346 + let mono_path = Monopam.Config.mono_path config in 1347 1347 + let subtree_path = Fpath.(mono_path / name) in 1348 1348 + let knot = Monopam.Config.knot config in 1349 1349 + let suggested = Monopam.Fork_join.suggest_push_url ~fs ~knot subtree_path in 1350 1350 + if yes || dry_run then 1351 1351 + suggested (* Use suggested or None without prompting *) 1352 1352 + else begin 1353 1353 + match suggested with 1354 1354 + | Some default_url -> 1355 1355 + Fmt.pr "Remote push URL [%s]: %!" default_url; 1356 1356 + (match prompt_string "" with 1357 1357 + | None -> Some default_url (* User pressed enter, use default *) 1358 1358 + | Some entered -> Some entered) 1359 1359 + | None -> 1360 1360 + Fmt.pr "Remote push URL (leave empty to skip): %!"; 1361 1361 + prompt_string "" 1362 1362 + end 1363 1363 + in 1364 1364 + (* Build the plan *) 1365 1365 + match Monopam.Fork_join.plan_fork ~proc ~fs ~config ~name ?push_url:url ~dry_run () with 1366 1366 + | Error e -> 1367 1367 + Fmt.epr "Error: %a@." Monopam.Fork_join.pp_error_with_hint e; 1368 1368 + `Error (false, "fork failed") 1369 1369 + | Ok plan -> 1370 1370 + (* Print discovery and actions *) 1371 1371 + Fmt.pr "Analyzing fork request for '%s'...@.@." name; 1372 1372 + Fmt.pr "Discovery:@.%a@." Monopam.Fork_join.pp_discovery plan.discovery; 1373 1373 + (match url with 1374 1374 + | Some u -> Fmt.pr " Remote URL: %s@." u 1375 1375 + | None -> ()); 1376 1376 + Fmt.pr "@.Actions to perform:@."; 1377 1377 + List.iteri (fun i action -> 1378 1378 + Fmt.pr " %d. %a@." (i + 1) Monopam.Fork_join.pp_action action 1379 1379 + ) plan.actions; 1380 1380 + Fmt.pr "@."; 1381 1381 + (* Prompt for confirmation unless --yes or --dry-run *) 1382 1382 + let proceed = 1383 1383 + if dry_run then begin 1384 1384 + Fmt.pr "(dry-run mode - no changes will be made)@."; 1385 1385 + true 1386 1386 + end else if yes then 1387 1387 + true 1388 1388 + else 1389 1389 + confirm "Proceed?" 1390 1390 + in 1391 1391 + if not proceed then begin 1392 1392 + Fmt.pr "Cancelled.@."; 1393 1393 + `Ok () 1394 1394 + end else begin 1395 1395 + (* Execute the plan *) 1396 1396 + match Monopam.Fork_join.execute_fork_plan ~proc ~fs plan with 1397 1397 + | Ok result -> 1398 1398 + if not dry_run then begin 1399 1399 + Fmt.pr "%a@." Monopam.Fork_join.pp_fork_result result; 1400 1400 + Fmt.pr "@.Next steps:@."; 1401 1401 + Fmt.pr " 1. Review the new repo: cd src/%s@." result.name; 1402 1402 + match url with 1403 1403 + | Some _ -> Fmt.pr " 2. Push to remote: git push -u origin main@." 1404 1404 + | None -> Fmt.pr " 2. Add a remote: git remote add origin <url>@." 1405 1405 + end; 1406 1406 + `Ok () 1407 1407 + | Error e -> 1408 1408 + Fmt.epr "Error: %a@." Monopam.Fork_join.pp_error_with_hint e; 1409 1409 + `Error (false, "fork failed") 1410 1410 + end 1411 1411 + in 1412 1412 + Cmd.v info Term.(ret (const run $ name_arg $ url_arg $ dry_run_arg $ yes_arg $ logging_term)) 1413 1413 + 1414 1414 + (* Join command *) 1415 1415 + 1416 1416 + let join_cmd = 1417 1417 + let doc = "Bring an external repository into the monorepo" in 1418 1418 + let man = 1419 1419 + [ 1420 1420 + `S Manpage.s_description; 1421 1421 + `P 1422 1422 + "Clones an external git repository and adds it as a subtree in the \ 1423 1423 + monorepo. This is the inverse of $(b,monopam fork)."; 1424 1424 + `S "JOIN MODES"; 1425 1425 + `P "The join command handles multiple scenarios:"; 1426 1426 + `I ("URL join", "Clone from a git URL and add as subtree (default)."); 1427 1427 + `I ("Local directory join", "Import from a local filesystem path. If the \ 1428 1428 + path is a git repo, uses it directly. If not, initializes a new repo."); 1429 1429 + `I ("Verse join", "Join from a verse member's repository using $(b,--from)."); 1430 1430 + `S "WHAT IT DOES"; 1431 1431 + `P "The join command:"; 1432 1432 + `I ("1.", "Analyzes the source (URL or local path)"); 1433 1433 + `I ("2.", "Builds an action plan and shows discovery details"); 1434 1434 + `I ("3.", "Prompts for confirmation (use $(b,--yes) to skip)"); 1435 1435 + `I ("4.", "Clones/copies the repository to src/<name>/"); 1436 1436 + `I ("5.", "Uses $(b,git subtree add) to bring into monorepo"); 1437 1437 + `I ("6.", "Updates sources.toml with $(b,origin = \"join\")"); 1438 1438 + `S "JOINING FROM VERSE"; 1439 1439 + `P "To join a package from a verse member, use $(b,--from):"; 1440 1440 + `Pre "monopam join --from avsm.bsky.social --url git@github.com:me/cohttp.git cohttp"; 1441 1441 + `P "This will:"; 1442 1442 + `I ("-", "Look up the package in their opam-repo"); 1443 1443 + `I ("-", "Find all packages from the same git repository"); 1444 1444 + `I ("-", "Create opam entries pointing to your fork"); 1445 1445 + `I ("-", "Clone and add the subtree"); 1446 1446 + `S "AFTER JOINING"; 1447 1447 + `P "After joining, work with the subtree normally:"; 1448 1448 + `I ("1.", "Make changes in mono/<name>/"); 1449 1449 + `I ("2.", "Commit in mono/"); 1450 1450 + `I ("3.", "Run $(b,monopam sync --remote) to push upstream"); 1451 1451 + `S Manpage.s_examples; 1452 1452 + `P "Join a repository:"; 1453 1453 + `Pre "monopam join https://github.com/someone/some-lib"; 1454 1454 + `P "Join from a local directory:"; 1455 1455 + `Pre "monopam join /path/to/local/repo --as my-lib"; 1456 1456 + `P "Join with explicit name using --url:"; 1457 1457 + `Pre "monopam join --url https://tangled.org/handle/sortal sortal"; 1458 1458 + `P "Join with a custom name using --as:"; 1459 1459 + `Pre "monopam join https://github.com/someone/some-lib --as my-lib"; 1460 1460 + `P "Join with upstream tracking (for forks):"; 1461 1461 + `Pre "monopam join https://github.com/me/cohttp --upstream https://github.com/mirage/cohttp"; 1462 1462 + `P "Join from a verse member:"; 1463 1463 + `Pre "monopam join cohttp --from avsm.bsky.social --url git@github.com:me/cohttp.git"; 1464 1464 + `P "Preview what would be done:"; 1465 1465 + `Pre "monopam join https://github.com/someone/lib --dry-run"; 1466 1466 + `P "Join without confirmation:"; 1467 1467 + `Pre "monopam join https://github.com/someone/lib --yes"; 1468 1468 + ] 1469 1469 + in 1470 1470 + let info = Cmd.info "join" ~doc ~man in 1471 1471 + let url_or_pkg_arg = 1472 1472 + let doc = "Git URL, local path, or subtree name (when using --url)" in 1473 1473 + Arg.(required & pos 0 (some string) None & info [] ~docv:"SOURCE" ~doc) 1474 1474 + in 1475 1475 + let as_arg = 1476 1476 + let doc = "Override subtree directory name" in 1477 1477 + Arg.(value & opt (some string) None & info [ "as" ] ~docv:"NAME" ~doc) 1478 1478 + in 1479 1479 + let upstream_arg = 1480 1480 + let doc = "Original upstream URL (for tracking forks)" in 1481 1481 + Arg.(value & opt (some string) None & info [ "upstream" ] ~docv:"URL" ~doc) 1482 1482 + in 1483 1483 + let from_arg = 1484 1484 + let doc = "Verse member handle to join from (requires --url)" in 1485 1485 + Arg.(value & opt (some string) None & info [ "from" ] ~docv:"HANDLE" ~doc) 1486 1486 + in 1487 1487 + let fork_url_arg = 1488 1488 + let doc = "Git URL to clone from (makes positional arg the subtree name)" in 1489 1489 + Arg.(value & opt (some string) None & info [ "url" ] ~docv:"URL" ~doc) 1490 1490 + in 1491 1491 + let dry_run_arg = 1492 1492 + let doc = "Show what would be done without making changes" in 1493 1493 + Arg.(value & flag & info [ "dry-run"; "n" ] ~doc) 1494 1494 + in 1495 1495 + let yes_arg = 1496 1496 + let doc = "Assume yes to all prompts (for automation)" in 1497 1497 + Arg.(value & flag & info [ "yes"; "y" ] ~doc) 1498 1498 + in 1499 1499 + let run url_or_pkg as_name upstream from fork_url dry_run yes () = 1500 1500 + Eio_main.run @@ fun env -> 1501 1501 + with_verse_config env @@ fun config -> 1502 1502 + let fs = Eio.Stdenv.fs env in 1503 1503 + let proc = Eio.Stdenv.process_mgr env in 1504 1504 + match from with 1505 1505 + | Some handle -> 1506 1506 + (* Join from verse member - requires --url for your fork *) 1507 1507 + (* Uses legacy API as it involves verse-specific operations *) 1508 1508 + (match fork_url with 1509 1509 + | None -> 1510 1510 + Fmt.epr "Error: --url is required when using --from@."; 1511 1511 + `Error (false, "--url required") 1512 1512 + | Some fork_url -> 1513 1513 + match Monopam.Fork_join.join_from_verse ~proc ~fs ~config ~verse_config:config 1514 1514 + ~package:url_or_pkg ~handle ~fork_url ~dry_run () with 1515 1515 + | Ok result -> 1516 1516 + if dry_run then begin 1517 1517 + Fmt.pr "Would join '%s' from %s:@." result.name (Option.value ~default:"verse" result.from_handle); 1518 1518 + Fmt.pr " Source: %s@." result.source_url; 1519 1519 + Option.iter (fun u -> Fmt.pr " Upstream: %s@." u) result.upstream_url; 1520 1520 + Fmt.pr " Packages: %a@." Fmt.(list ~sep:(any ", ") string) result.packages_added 1521 1521 + end else begin 1522 1522 + Fmt.pr "%a@." Monopam.Fork_join.pp_join_result result; 1523 1523 + Fmt.pr "@.Next steps:@."; 1524 1524 + Fmt.pr " 1. Commit the opam changes: cd opam-repo && git add -A && git commit@."; 1525 1525 + Fmt.pr " 2. Run $(b,monopam sync) to synchronize@." 1526 1526 + end; 1527 1527 + `Ok () 1528 1528 + | Error e -> 1529 1529 + Fmt.epr "Error: %a@." Monopam.Fork_join.pp_error_with_hint e; 1530 1530 + `Error (false, "join failed")) 1531 1531 + | None -> 1532 1532 + (* Normal join from URL or local path - use plan-based workflow *) 1533 1533 + let source = match fork_url with Some u -> u | None -> url_or_pkg in 1534 1534 + let name = match fork_url with Some _ -> Some url_or_pkg | None -> as_name in 1535 1535 + (* Build the plan *) 1536 1536 + match Monopam.Fork_join.plan_join ~proc ~fs ~config ~source ?name ?upstream ~dry_run () with 1537 1537 + | Error e -> 1538 1538 + Fmt.epr "Error: %a@." Monopam.Fork_join.pp_error_with_hint e; 1539 1539 + `Error (false, "join failed") 1540 1540 + | Ok plan -> 1541 1541 + (* Print discovery and actions *) 1542 1542 + let is_local = Monopam.Fork_join.is_local_path source in 1543 1543 + Fmt.pr "Analyzing join request...@.@."; 1544 1544 + Fmt.pr "Discovery:@."; 1545 1545 + Fmt.pr " Source: %s (%s)@." source 1546 1546 + (if is_local then "local directory" else "remote URL"); 1547 1547 + Fmt.pr "%a" Monopam.Fork_join.pp_discovery plan.discovery; 1548 1548 + Fmt.pr "@.Actions to perform:@."; 1549 1549 + List.iteri (fun i action -> 1550 1550 + Fmt.pr " %d. %a@." (i + 1) Monopam.Fork_join.pp_action action 1551 1551 + ) plan.actions; 1552 1552 + Fmt.pr "@."; 1553 1553 + (* Prompt for confirmation unless --yes or --dry-run *) 1554 1554 + let proceed = 1555 1555 + if dry_run then begin 1556 1556 + Fmt.pr "(dry-run mode - no changes will be made)@."; 1557 1557 + true 1558 1558 + end else if yes then 1559 1559 + true 1560 1560 + else 1561 1561 + confirm "Proceed?" 1562 1562 + in 1563 1563 + if not proceed then begin 1564 1564 + Fmt.pr "Cancelled.@."; 1565 1565 + `Ok () 1566 1566 + end else begin 1567 1567 + (* Execute the plan *) 1568 1568 + match Monopam.Fork_join.execute_join_plan ~proc ~fs plan with 1569 1569 + | Ok result -> 1570 1570 + if not dry_run then begin 1571 1571 + Fmt.pr "%a@." Monopam.Fork_join.pp_join_result result; 1572 1572 + Fmt.pr "@.Next steps:@."; 1573 1573 + Fmt.pr " 1. Run $(b,monopam sync) to synchronize@." 1574 1574 + end; 1575 1575 + `Ok () 1576 1576 + | Error e -> 1577 1577 + Fmt.epr "Error: %a@." Monopam.Fork_join.pp_error_with_hint e; 1578 1578 + `Error (false, "join failed") 1579 1579 + end 1580 1580 + in 1581 1581 + Cmd.v info Term.(ret (const run $ url_or_pkg_arg $ as_arg $ upstream_arg $ from_arg $ fork_url_arg $ dry_run_arg $ yes_arg $ logging_term)) 1582 1582 + 1583 1583 + (* Rejoin command *) 1584 1584 + 1585 1585 + let rejoin_cmd = 1586 1586 + let doc = "Add a source checkout back into the monorepo as a subtree" in 1587 1587 + let man = 1588 1588 + [ 1589 1589 + `S Manpage.s_description; 1590 1590 + `P 1591 1591 + "Adds an existing src/<name>/ repository back into mono/<name>/ as a \ 1592 1592 + subtree. This is useful after forking a package and removing it from \ 1593 1593 + the monorepo with $(b,git rm)."; 1594 1594 + `S "WORKFLOW"; 1595 1595 + `P "Typical workflow for removing and re-adding a package:"; 1596 1596 + `I ("1.", "Fork the package: $(b,monopam fork my-lib)"); 1597 1597 + `I ("2.", "Remove from monorepo: $(b,git rm -r mono/my-lib && git commit)"); 1598 1598 + `I ("3.", "Work on it in src/my-lib/"); 1599 1599 + `I ("4.", "Re-add to monorepo: $(b,monopam rejoin my-lib)"); 1600 1600 + `S "REQUIREMENTS"; 1601 1601 + `P "For rejoin to work:"; 1602 1602 + `I ("-", "src/<name>/ must exist and be a git repository"); 1603 1603 + `I ("-", "mono/<name>/ must NOT exist (was removed)"); 1604 1604 + `S "WHAT IT DOES"; 1605 1605 + `P "The rejoin command:"; 1606 1606 + `I ("1.", "Verifies src/<name>/ exists and is a git repo"); 1607 1607 + `I ("2.", "Verifies mono/<name>/ does not exist"); 1608 1608 + `I ("3.", "Prompts for confirmation (use $(b,--yes) to skip)"); 1609 1609 + `I ("4.", "Uses $(b,git subtree add) to bring src/<name>/ into mono/<name>/"); 1610 1610 + `S Manpage.s_examples; 1611 1611 + `P "Re-add a package from src/:"; 1612 1612 + `Pre "monopam rejoin my-lib"; 1613 1613 + `P "Preview what would be done:"; 1614 1614 + `Pre "monopam rejoin my-lib --dry-run"; 1615 1615 + `P "Rejoin without confirmation:"; 1616 1616 + `Pre "monopam rejoin my-lib --yes"; 1617 1617 + ] 1618 1618 + in 1619 1619 + let info = Cmd.info "rejoin" ~doc ~man in 1620 1620 + let name_arg = 1621 1621 + let doc = "Name of the subtree to rejoin (directory name under src/)" in 1622 1622 + Arg.(required & pos 0 (some string) None & info [] ~docv:"NAME" ~doc) 1623 1623 + in 1624 1624 + let dry_run_arg = 1625 1625 + let doc = "Show what would be done without making changes" in 1626 1626 + Arg.(value & flag & info [ "dry-run"; "n" ] ~doc) 1627 1627 + in 1628 1628 + let yes_arg = 1629 1629 + let doc = "Assume yes to all prompts (for automation)" in 1630 1630 + Arg.(value & flag & info [ "yes"; "y" ] ~doc) 1631 1631 + in 1632 1632 + let run name dry_run yes () = 1633 1633 + Eio_main.run @@ fun env -> 1634 1634 + with_verse_config env @@ fun config -> 1635 1635 + let fs = Eio.Stdenv.fs env in 1636 1636 + let proc = Eio.Stdenv.process_mgr env in 1637 1637 + (* Build the plan *) 1638 1638 + match Monopam.Fork_join.plan_rejoin ~proc ~fs ~config ~name ~dry_run () with 1639 1639 + | Error e -> 1640 1640 + Fmt.epr "Error: %a@." Monopam.Fork_join.pp_error_with_hint e; 1641 1641 + `Error (false, "rejoin failed") 1642 1642 + | Ok plan -> 1643 1643 + (* Print discovery and actions *) 1644 1644 + Fmt.pr "Analyzing rejoin request for '%s'...@.@." name; 1645 1645 + Fmt.pr "Discovery:@.%a@." Monopam.Fork_join.pp_discovery plan.discovery; 1646 1646 + Fmt.pr "@.Actions to perform:@."; 1647 1647 + List.iteri (fun i action -> 1648 1648 + Fmt.pr " %d. %a@." (i + 1) Monopam.Fork_join.pp_action action 1649 1649 + ) plan.actions; 1650 1650 + Fmt.pr "@."; 1651 1651 + (* Prompt for confirmation unless --yes or --dry-run *) 1652 1652 + let proceed = 1653 1653 + if dry_run then begin 1654 1654 + Fmt.pr "(dry-run mode - no changes will be made)@."; 1655 1655 + true 1656 1656 + end else if yes then 1657 1657 + true 1658 1658 + else 1659 1659 + confirm "Proceed?" 1660 1660 + in 1661 1661 + if not proceed then begin 1662 1662 + Fmt.pr "Cancelled.@."; 1663 1663 + `Ok () 1664 1664 + end else begin 1665 1665 + (* Execute the plan *) 1666 1666 + match Monopam.Fork_join.execute_join_plan ~proc ~fs plan with 1667 1667 + | Ok result -> 1668 1668 + if not dry_run then begin 1669 1669 + Fmt.pr "%a@." Monopam.Fork_join.pp_join_result result; 1670 1670 + Fmt.pr "@.Next steps:@."; 1671 1671 + Fmt.pr " 1. Commit the changes: git add -A && git commit@."; 1672 1672 + Fmt.pr " 2. Run $(b,monopam sync) to synchronize@." 1673 1673 + end; 1674 1674 + `Ok () 1675 1675 + | Error e -> 1676 1676 + Fmt.epr "Error: %a@." Monopam.Fork_join.pp_error_with_hint e; 1677 1677 + `Error (false, "rejoin failed") 1678 1678 + end 1679 1679 + in 1680 1680 + Cmd.v info Term.(ret (const run $ name_arg $ dry_run_arg $ yes_arg $ logging_term)) 1681 1681 + 1682 1682 + (* Site command *) 1683 1683 + 1684 1684 + let site_cmd = 1685 1685 + let doc = "Generate a static HTML site representing the monoverse map" in 1686 1686 + let man = 1687 1687 + [ 1688 1688 + `S Manpage.s_description; 1689 1689 + `P 1690 1690 + "Generates a static index.html file that maps the monoverse, showing all \ 1691 1691 + verse members, their packages, and the relationships between them."; 1692 1692 + `S "OUTPUT"; 1693 1693 + `P "The generated site includes:"; 1694 1694 + `I ("Members", "All verse members with links to their monorepo and opam repos"); 1695 1695 + `I ("Summary", "Overview of common libraries and member-specific packages"); 1696 1696 + `I ("Repository Details", "Each shared repo with packages and fork status"); 1697 1697 + `S "FORK STATUS"; 1698 1698 + `P "Use $(b,--status) to include fork relationship information:"; 1699 1699 + `I ("+N", "You are N commits ahead of them"); 1700 1700 + `I ("-N", "They are N commits ahead of you"); 1701 1701 + `I ("+N/-M", "Diverged: you have N new, they have M new"); 1702 1702 + `I ("sync", "Same commit"); 1703 1703 + `S "DESIGN"; 1704 1704 + `P "The HTML is designed to be:"; 1705 1705 + `I ("-", "Simple and clean with a 10pt font"); 1706 1706 + `I ("-", "Responsive and compact"); 1707 1707 + `I ("-", "External links marked with icon and teal color"); 1708 1708 + `S Manpage.s_examples; 1709 1709 + `P "Generate site to default location (mono/index.html):"; 1710 1710 + `Pre "monopam site"; 1711 1711 + `P "Generate site with fork status (slower, fetches remotes):"; 1712 1712 + `Pre "monopam site --status"; 1713 1713 + `P "Generate site to custom location:"; 1714 1714 + `Pre "monopam site -o /var/www/monoverse/index.html"; 1715 1715 + `P "Print HTML to stdout:"; 1716 1716 + `Pre "monopam site --stdout"; 1717 1717 + ] 1718 1718 + in 1719 1719 + let info = Cmd.info "site" ~doc ~man in 1720 1720 + let output_arg = 1721 1721 + let doc = "Output file path. Defaults to mono/index.html." in 1722 1722 + Arg.(value & opt (some string) None & info [ "o"; "output" ] ~docv:"FILE" ~doc) 1723 1723 + in 1724 1724 + let stdout_arg = 1725 1725 + let doc = "Print HTML to stdout instead of writing to file." in 1726 1726 + Arg.(value & flag & info [ "stdout" ] ~doc) 1727 1727 + in 1728 1728 + let status_arg = 1729 1729 + let doc = "Include fork status (ahead/behind) for each repository. \ 1730 1730 + This fetches from remotes and may be slower." in 1731 1731 + Arg.(value & flag & info [ "status"; "s" ] ~doc) 1732 1732 + in 1733 1733 + let run output to_stdout with_status () = 1734 1734 + Eio_main.run @@ fun env -> 1735 1735 + with_config env @@ fun monopam_config -> 1736 1736 + with_verse_config env @@ fun verse_config -> 1737 1737 + let fs = Eio.Stdenv.fs env in 1738 1738 + let proc = Eio.Stdenv.process_mgr env in 1739 1739 + (* Pull/clone registry to get latest metadata *) 1740 1740 + Fmt.pr "Syncing registry...@."; 1741 1741 + let registry = 1742 1742 + match Monopam.Verse_registry.clone_or_pull ~proc ~fs:(fs :> _ Eio.Path.t) ~config:verse_config () with 1743 1743 + | Ok r -> r 1744 1744 + | Error msg -> 1745 1745 + Fmt.epr "Warning: Could not sync registry: %s@." msg; 1746 1746 + Monopam.Verse_registry.{ name = "opamverse"; description = None; members = [] } 1747 1747 + in 1748 1748 + (* Compute forks if --status is requested *) 1749 1749 + let forks = 1750 1750 + if with_status then begin 1751 1751 + Fmt.pr "Computing fork status...@."; 1752 1752 + Some (Monopam.Forks.compute ~proc ~fs:(fs :> _ Eio.Path.t) 1753 1753 + ~verse_config ~monopam_config ()) 1754 1754 + end else None 1755 1755 + in 1756 1756 + if to_stdout then begin 1757 1757 + let html = Monopam.Site.generate ~fs:(fs :> _ Eio.Path.t) ~config:verse_config ?forks ~registry () in 1758 1758 + print_string html; 1759 1759 + `Ok () 1760 1760 + end else begin 1761 1761 + let output_path = 1762 1762 + match output with 1763 1763 + | Some p -> ( 1764 1764 + match Fpath.of_string p with 1765 1765 + | Ok fp -> fp 1766 1766 + | Error (`Msg _) -> Fpath.v p) 1767 1767 + | None -> Fpath.(Monopam.Verse_config.mono_path verse_config / "index.html") 1768 1768 + in 1769 1769 + match Monopam.Site.write ~fs:(fs :> _ Eio.Path.t) ~config:verse_config ?forks ~registry ~output_path () with 1770 1770 + | Ok () -> 1771 1771 + Fmt.pr "Site generated: %a@." Fpath.pp output_path; 1772 1772 + `Ok () 1773 1773 + | Error msg -> 1774 1774 + Fmt.epr "Error: %s@." msg; 1775 1775 + `Error (false, "site generation failed") 1776 1776 + end 1777 1777 + in 1778 1778 + Cmd.v info Term.(ret (const run $ output_arg $ stdout_arg $ status_arg $ logging_term)) 1779 1779 + 1041 1780 (* Main command group *) 1042 1781 1043 1782 let main_cmd = ··· 1048 1787 `P 1049 1788 "Monopam synchronizes packages between an opam overlay repository, \ 1050 1789 individual git checkouts, and a monorepo using git subtrees."; 1790 1790 + `P 1791 1791 + "Monopam is designed to run inside a devcontainer that provides a \ 1792 1792 + consistent OCaml development environment with all required tools \ 1793 1793 + pre-installed."; 1051 1794 `S "QUICK START"; 1052 1052 - `P "First time setup:"; 1795 1795 + `P "Start by creating a devcontainer workspace:"; 1796 1796 + `Pre 1797 1797 + "monopam devcontainer ~/tangled"; 1798 1798 + `P "Inside the devcontainer, initialize your workspace:"; 1053 1799 `Pre 1054 1054 - "mkdir ~/tangled && cd ~/tangled\n\ 1055 1055 - monopam verse init --handle yourname.bsky.social\n\ 1800 1800 + "cd ~/tangled\n\ 1801 1801 + monopam init --handle yourname.bsky.social\n\ 1056 1802 cd mono"; 1057 1803 `P "Daily workflow:"; 1058 1804 `Pre ··· 1065 1811 `P "Monopam manages three directory trees:"; 1066 1812 `I 1067 1813 ( "mono/", 1068 1068 - "The monorepo combining all packages as git subtrees. This is where you \ 1069 1069 - make changes." ); 1814 1814 + "The monorepo combining all packages as git subtrees. This is where \ 1815 1815 + you make changes." ); 1070 1816 `I 1071 1817 ( "src/", 1072 1818 "Individual git checkouts of each unique repository. Used for review \ ··· 1085 1831 `I 1086 1832 ( "4. monopam sync --remote", 1087 1833 "Sync again, including pushing to upstream git remotes" ); 1088 1088 - `P 1089 1089 - "For finer control, use $(b,push) and $(b,pull) separately:"; 1834 1834 + `P "For finer control over the sync phases:"; 1090 1835 `I 1091 1091 - ( "monopam push", 1092 1092 - "Export monorepo changes to checkouts (for manual review/push)" ); 1836 1836 + ( "monopam sync --skip-pull", 1837 1837 + "Export monorepo changes to checkouts only (skip fetching remotes)" ); 1093 1838 `I 1094 1094 - ( "monopam pull", 1095 1095 - "Pull remote changes into monorepo (when you know there are no local changes)" ); 1839 1839 + ( "monopam sync --skip-push", 1840 1840 + "Pull remote changes only (skip exporting local changes)" ); 1096 1841 `S "CHECKING STATUS"; 1097 1842 `P "Run $(b,monopam status) to see the state of all repositories:"; 1098 1843 `I ("local:+N", "Your monorepo is N commits ahead of the checkout"); ··· 1101 1846 `I ("remote:+N", "Your checkout is N commits ahead of upstream"); 1102 1847 `I ("remote:-N", "Upstream is N commits ahead (run $(b,monopam sync))"); 1103 1848 `S "COMMON TASKS"; 1104 1104 - `I ("Start fresh", "monopam verse init --handle you.bsky.social"); 1849 1849 + `I ("Start fresh", "monopam init --handle you.bsky.social"); 1105 1850 `I ("Check status", "monopam status"); 1106 1851 `I ("Sync everything", "monopam sync"); 1107 1852 `I ("Sync and push upstream", "monopam sync --remote"); 1108 1853 `I ("Sync one package", "monopam sync <package-name>"); 1109 1854 `S "CONFIGURATION"; 1110 1855 `P 1111 1111 - "Run $(b,monopam verse init --handle <handle>) to create a workspace. \ 1856 1856 + "Run $(b,monopam init --handle <handle>) to create a workspace. \ 1112 1857 Configuration is stored in ~/.config/monopam/opamverse.toml."; 1113 1858 `P "Workspace structure:"; 1114 1859 `Pre ··· 1133 1878 in 1134 1879 let info = Cmd.info "monopam" ~version:"%%VERSION%%" ~doc ~man in 1135 1880 Cmd.group info 1136 1136 - [ status_cmd; sync_cmd; changes_cmd; opam_cmd; doctor_cmd; verse_cmd; feature_cmd ] 1881 1881 + [ init_cmd; status_cmd; diff_cmd; pull_cmd; cherrypick_cmd; sync_cmd; changes_cmd; opam_cmd; doctor_cmd; verse_cmd; feature_cmd; fork_cmd; join_cmd; rejoin_cmd; devcontainer_cmd; site_cmd ] 1137 1882 1138 1883 let () = exit (Cmd.eval main_cmd)

+2

dune-project

reviewed

··· 32 32 (jsont (>= 0.2.0)) 33 33 requests 34 34 (ptime (>= 1.0.0)) 35 35 + (sexplib0 (>= 0.17.0)) 36 36 + (parsexp (>= 0.17.0)) 35 37 (odoc :with-doc))) 36 38

+475 -353

lib/changes.ml

reviewed

··· 1 1 (** Changelog generation for monopam. 2 2 3 3 - This module handles generating weekly and daily changelog entries using Claude AI 4 4 - to analyze git commit history and produce user-facing change summaries. 3 3 + This module handles generating weekly and daily changelog entries using 4 4 + Claude AI to analyze git commit history and produce user-facing change 5 5 + summaries. 5 6 6 7 Changes are stored in a .changes directory at the monorepo root: 7 8 - .changes/<repo_name>.json - weekly changelog entries 8 8 - - .changes/<repo_name>-<YYYY-MM-DD>.json - daily changelog entries (one file per day per repo) 9 9 + - .changes/<repo_name>-<YYYY-MM-DD>.json - daily changelog entries (one file 10 10 + per day per repo) 9 11 - .changes/YYYYMMDD.json - aggregated daily changes for broadcasting 10 12 11 13 {1 Submodules} 12 14 13 15 - {!Aggregated} - Types and I/O for aggregated daily changes (YYYYMMDD.json) 14 14 - - {!Daily} - Types and I/O for per-day-per-repo changes (repo-YYYY-MM-DD.json) 16 16 + - {!Daily} - Types and I/O for per-day-per-repo changes 17 17 + (repo-YYYY-MM-DD.json) 15 18 - {!Query} - High-level query interface for changes *) 16 19 20 20 + module Aggregated = Changes_aggregated 17 21 (** Re-export submodules for querying changes *) 18 18 - module Aggregated = Changes_aggregated 22 22 + 19 23 module Daily = Changes_daily 20 24 module Query = Changes_query 21 25 22 22 - type commit_range = { 23 23 - from_hash : string; 24 24 - to_hash : string; 25 25 - count : int; 26 26 - } 26 26 + type commit_range = { from_hash : string; to_hash : string; count : int } 27 27 28 28 type weekly_entry = { 29 29 - week_start : string; (* ISO date YYYY-MM-DD, Monday *) 30 30 - week_end : string; (* ISO date YYYY-MM-DD, Sunday *) 31 31 - summary : string; (* One-line summary *) 29 29 + week_start : string; (* ISO date YYYY-MM-DD, Monday *) 30 30 + week_end : string; (* ISO date YYYY-MM-DD, Sunday *) 31 31 + summary : string; (* One-line summary *) 32 32 changes : string list; (* Bullet points *) 33 33 commit_range : commit_range; 34 34 } 35 35 36 36 type daily_entry = { 37 37 - date : string; (* ISO date YYYY-MM-DD *) 38 38 - hour : int; (* Hour of day 0-23 *) 39 39 - timestamp : Ptime.t; (* RFC3339 timestamp for precise ordering *) 40 40 - summary : string; (* One-line summary *) 37 37 + date : string; (* ISO date YYYY-MM-DD *) 38 38 + hour : int; (* Hour of day 0-23 *) 39 39 + timestamp : Ptime.t; (* RFC3339 timestamp for precise ordering *) 40 40 + summary : string; (* One-line summary *) 41 41 changes : string list; (* Bullet points *) 42 42 commit_range : commit_range; 43 43 contributors : string list; (* List of contributors for this entry *) 44 44 repo_url : string option; (* Upstream repository URL *) 45 45 } 46 46 47 47 - type changes_file = { 48 48 - repository : string; 49 49 - entries : weekly_entry list; 50 50 - } 51 51 - 52 52 - type daily_changes_file = { 53 53 - repository : string; 54 54 - entries : daily_entry list; 55 55 - } 47 47 + type changes_file = { repository : string; entries : weekly_entry list } 48 48 + type daily_changes_file = { repository : string; entries : daily_entry list } 56 49 57 50 (** Mode for changelog generation *) 58 51 type mode = Weekly | Daily ··· 72 65 { week_start; week_end; summary; changes; commit_range } 73 66 in 74 67 Jsont.Object.map ~kind:"weekly_entry" make 75 75 - |> Jsont.Object.mem "week_start" Jsont.string ~enc:(fun (e : weekly_entry) -> e.week_start) 76 76 - |> Jsont.Object.mem "week_end" Jsont.string ~enc:(fun (e : weekly_entry) -> e.week_end) 77 77 - |> Jsont.Object.mem "summary" Jsont.string ~enc:(fun (e : weekly_entry) -> e.summary) 78 78 - |> Jsont.Object.mem "changes" (Jsont.list Jsont.string) ~enc:(fun (e : weekly_entry) -> e.changes) 79 79 - |> Jsont.Object.mem "commit_range" commit_range_jsont ~enc:(fun (e : weekly_entry) -> e.commit_range) 68 68 + |> Jsont.Object.mem "week_start" Jsont.string ~enc:(fun (e : weekly_entry) -> 69 69 + e.week_start) 70 70 + |> Jsont.Object.mem "week_end" Jsont.string ~enc:(fun (e : weekly_entry) -> 71 71 + e.week_end) 72 72 + |> Jsont.Object.mem "summary" Jsont.string ~enc:(fun (e : weekly_entry) -> 73 73 + e.summary) 74 74 + |> Jsont.Object.mem "changes" (Jsont.list Jsont.string) 75 75 + ~enc:(fun (e : weekly_entry) -> e.changes) 76 76 + |> Jsont.Object.mem "commit_range" commit_range_jsont 77 77 + ~enc:(fun (e : weekly_entry) -> e.commit_range) 80 78 |> Jsont.Object.finish 81 79 82 80 let changes_file_jsont : changes_file Jsont.t = 83 81 let make repository entries : changes_file = { repository; entries } in 84 82 Jsont.Object.map ~kind:"changes_file" make 85 85 - |> Jsont.Object.mem "repository" Jsont.string ~enc:(fun (f : changes_file) -> f.repository) 86 86 - |> Jsont.Object.mem "entries" (Jsont.list weekly_entry_jsont) ~enc:(fun (f : changes_file) -> f.entries) 83 83 + |> Jsont.Object.mem "repository" Jsont.string ~enc:(fun (f : changes_file) -> 84 84 + f.repository) 85 85 + |> Jsont.Object.mem "entries" (Jsont.list weekly_entry_jsont) 86 86 + ~enc:(fun (f : changes_file) -> f.entries) 87 87 |> Jsont.Object.finish 88 88 89 89 let ptime_jsont = 90 90 - let enc t = 91 91 - Ptime.to_rfc3339 t ~tz_offset_s:0 92 92 - in 90 90 + let enc t = Ptime.to_rfc3339 t ~tz_offset_s:0 in 93 91 let dec s = 94 92 match Ptime.of_rfc3339 s with 95 93 | Ok (t, _, _) -> t ··· 98 96 Jsont.map ~dec ~enc Jsont.string 99 97 100 98 let daily_entry_jsont : daily_entry Jsont.t = 101 101 - let make date hour timestamp summary changes commit_range contributors repo_url : daily_entry = 102 102 - { date; hour; timestamp; summary; changes; commit_range; contributors; repo_url } 99 99 + let make date hour timestamp summary changes commit_range contributors 100 100 + repo_url : daily_entry = 101 101 + { 102 102 + date; 103 103 + hour; 104 104 + timestamp; 105 105 + summary; 106 106 + changes; 107 107 + commit_range; 108 108 + contributors; 109 109 + repo_url; 110 110 + } 103 111 in 104 112 (* Default hour and timestamp for backwards compat when reading old files *) 105 113 let default_hour = 0 in 106 114 let default_timestamp = Ptime.epoch in 107 115 Jsont.Object.map ~kind:"daily_entry" make 108 116 |> Jsont.Object.mem "date" Jsont.string ~enc:(fun (e : daily_entry) -> e.date) 109 109 - |> Jsont.Object.mem "hour" Jsont.int ~dec_absent:default_hour ~enc:(fun (e : daily_entry) -> e.hour) 110 110 - |> Jsont.Object.mem "timestamp" ptime_jsont ~dec_absent:default_timestamp ~enc:(fun (e : daily_entry) -> e.timestamp) 111 111 - |> Jsont.Object.mem "summary" Jsont.string ~enc:(fun (e : daily_entry) -> e.summary) 112 112 - |> Jsont.Object.mem "changes" (Jsont.list Jsont.string) ~enc:(fun (e : daily_entry) -> e.changes) 113 113 - |> Jsont.Object.mem "commit_range" commit_range_jsont ~enc:(fun (e : daily_entry) -> e.commit_range) 114 114 - |> Jsont.Object.mem "contributors" (Jsont.list Jsont.string) ~dec_absent:[] ~enc:(fun (e : daily_entry) -> e.contributors) 115 115 - |> Jsont.Object.mem "repo_url" (Jsont.option Jsont.string) ~dec_absent:None ~enc:(fun (e : daily_entry) -> e.repo_url) 117 117 + |> Jsont.Object.mem "hour" Jsont.int ~dec_absent:default_hour 118 118 + ~enc:(fun (e : daily_entry) -> e.hour) 119 119 + |> Jsont.Object.mem "timestamp" ptime_jsont ~dec_absent:default_timestamp 120 120 + ~enc:(fun (e : daily_entry) -> e.timestamp) 121 121 + |> Jsont.Object.mem "summary" Jsont.string ~enc:(fun (e : daily_entry) -> 122 122 + e.summary) 123 123 + |> Jsont.Object.mem "changes" (Jsont.list Jsont.string) 124 124 + ~enc:(fun (e : daily_entry) -> e.changes) 125 125 + |> Jsont.Object.mem "commit_range" commit_range_jsont 126 126 + ~enc:(fun (e : daily_entry) -> e.commit_range) 127 127 + |> Jsont.Object.mem "contributors" (Jsont.list Jsont.string) ~dec_absent:[] 128 128 + ~enc:(fun (e : daily_entry) -> e.contributors) 129 129 + |> Jsont.Object.mem "repo_url" (Jsont.option Jsont.string) ~dec_absent:None 130 130 + ~enc:(fun (e : daily_entry) -> e.repo_url) 116 131 |> Jsont.Object.finish 117 132 118 133 let daily_changes_file_jsont : daily_changes_file Jsont.t = 119 134 let make repository entries : daily_changes_file = { repository; entries } in 120 135 Jsont.Object.map ~kind:"daily_changes_file" make 121 121 - |> Jsont.Object.mem "repository" Jsont.string ~enc:(fun (f : daily_changes_file) -> f.repository) 122 122 - |> Jsont.Object.mem "entries" (Jsont.list daily_entry_jsont) ~enc:(fun (f : daily_changes_file) -> f.entries) 136 136 + |> Jsont.Object.mem "repository" Jsont.string 137 137 + ~enc:(fun (f : daily_changes_file) -> f.repository) 138 138 + |> Jsont.Object.mem "entries" (Jsont.list daily_entry_jsont) 139 139 + ~enc:(fun (f : daily_changes_file) -> f.entries) 123 140 |> Jsont.Object.finish 124 141 125 142 (* File I/O *) ··· 134 151 135 152 (* Load weekly changes from .changes/<repo>.json in monorepo *) 136 153 let load ~fs ~monorepo repo_name = 137 137 - let file_path = Eio.Path.(fs / Fpath.to_string monorepo / ".changes" / (repo_name ^ ".json")) in 154 154 + let file_path = 155 155 + Eio.Path.( 156 156 + fs / Fpath.to_string monorepo / ".changes" / (repo_name ^ ".json")) 157 157 + in 138 158 match Eio.Path.kind ~follow:true file_path with 139 159 | `Regular_file -> ( 140 160 let content = Eio.Path.load file_path in 141 161 match Jsont_bytesrw.decode_string changes_file_jsont content with 142 162 | Ok cf -> Ok cf 143 143 - | Error e -> Error (Format.sprintf "Failed to parse %s.json: %s" repo_name e)) 163 163 + | Error e -> 164 164 + Error (Format.sprintf "Failed to parse %s.json: %s" repo_name e)) 144 165 | _ -> Ok { repository = repo_name; entries = [] } 145 166 | exception Eio.Io _ -> Ok { repository = repo_name; entries = [] } 146 167 147 168 (* Save weekly changes to .changes/<repo>.json in monorepo *) 148 169 let save ~fs ~monorepo (cf : changes_file) = 149 170 ensure_changes_dir ~fs monorepo; 150 150 - let file_path = Eio.Path.(fs / Fpath.to_string monorepo / ".changes" / (cf.repository ^ ".json")) in 151 151 - match Jsont_bytesrw.encode_string ~format:Jsont.Indent changes_file_jsont cf with 171 171 + let file_path = 172 172 + Eio.Path.( 173 173 + fs / Fpath.to_string monorepo / ".changes" / (cf.repository ^ ".json")) 174 174 + in 175 175 + match 176 176 + Jsont_bytesrw.encode_string ~format:Jsont.Indent changes_file_jsont cf 177 177 + with 152 178 | Ok content -> 153 179 Eio.Path.save ~create:(`Or_truncate 0o644) file_path content; 154 180 Ok () 155 155 - | Error e -> Error (Format.sprintf "Failed to encode %s.json: %s" cf.repository e) 181 181 + | Error e -> 182 182 + Error (Format.sprintf "Failed to encode %s.json: %s" cf.repository e) 156 183 157 184 (* Filename for daily changes: <repo>-<YYYY-MM-DD>.json *) 158 158 - let daily_filename repo_name date = 159 159 - repo_name ^ "-" ^ date ^ ".json" 185 185 + let daily_filename repo_name date = repo_name ^ "-" ^ date ^ ".json" 160 186 161 187 (* Check if daily file exists on disk *) 162 188 let daily_exists ~fs ~monorepo ~date repo_name = 163 189 let filename = daily_filename repo_name date in 164 164 - let file_path = Eio.Path.(fs / Fpath.to_string monorepo / ".changes" / filename) in 190 190 + let file_path = 191 191 + Eio.Path.(fs / Fpath.to_string monorepo / ".changes" / filename) 192 192 + in 165 193 match Eio.Path.kind ~follow:true file_path with 166 194 | `Regular_file -> true 167 195 | _ -> false ··· 170 198 (* Load daily changes from .changes/<repo>-<date>.json in monorepo *) 171 199 let load_daily ~fs ~monorepo ~date repo_name = 172 200 let filename = daily_filename repo_name date in 173 173 - let file_path = Eio.Path.(fs / Fpath.to_string monorepo / ".changes" / filename) in 201 201 + let file_path = 202 202 + Eio.Path.(fs / Fpath.to_string monorepo / ".changes" / filename) 203 203 + in 174 204 match Eio.Path.kind ~follow:true file_path with 175 205 | `Regular_file -> ( 176 206 let content = Eio.Path.load file_path in ··· 184 214 let save_daily ~fs ~monorepo ~date (cf : daily_changes_file) = 185 215 ensure_changes_dir ~fs monorepo; 186 216 let filename = daily_filename cf.repository date in 187 187 - let file_path = Eio.Path.(fs / Fpath.to_string monorepo / ".changes" / filename) in 188 188 - match Jsont_bytesrw.encode_string ~format:Jsont.Indent daily_changes_file_jsont cf with 217 217 + let file_path = 218 218 + Eio.Path.(fs / Fpath.to_string monorepo / ".changes" / filename) 219 219 + in 220 220 + match 221 221 + Jsont_bytesrw.encode_string ~format:Jsont.Indent daily_changes_file_jsont cf 222 222 + with 189 223 | Ok content -> 190 224 Eio.Path.save ~create:(`Or_truncate 0o644) file_path content; 191 225 Ok () ··· 196 230 let to_markdown (cf : changes_file) = 197 231 let buf = Buffer.create 1024 in 198 232 Buffer.add_string buf (Printf.sprintf "# %s Changelog\n\n" cf.repository); 199 199 - List.iter (fun (entry : weekly_entry) -> 200 200 - Buffer.add_string buf (Printf.sprintf "## Week of %s to %s\n\n" entry.week_start entry.week_end); 201 201 - Buffer.add_string buf (Printf.sprintf "%s\n\n" entry.summary); 202 202 - List.iter (fun change -> 203 203 - Buffer.add_string buf (Printf.sprintf "- %s\n" change)) 204 204 - entry.changes; 205 205 - Buffer.add_string buf "\n") 233 233 + List.iter 234 234 + (fun (entry : weekly_entry) -> 235 235 + Buffer.add_string buf 236 236 + (Printf.sprintf "## Week of %s to %s\n\n" entry.week_start 237 237 + entry.week_end); 238 238 + Buffer.add_string buf (Printf.sprintf "%s\n\n" entry.summary); 239 239 + List.iter 240 240 + (fun change -> Buffer.add_string buf (Printf.sprintf "- %s\n" change)) 241 241 + entry.changes; 242 242 + Buffer.add_string buf "\n") 206 243 cf.entries; 207 244 Buffer.contents buf 208 245 209 246 let aggregate ~history (cfs : changes_file list) = 210 247 (* Collect all entries from all files, tagged with repository *) 211 248 let all_entries = 212 212 - List.concat_map (fun (cf : changes_file) -> 213 213 - List.map (fun (e : weekly_entry) -> (cf.repository, e)) cf.entries) 249 249 + List.concat_map 250 250 + (fun (cf : changes_file) -> 251 251 + List.map (fun (e : weekly_entry) -> (cf.repository, e)) cf.entries) 214 252 cfs 215 253 in 216 254 (* Sort by week_start descending *) 217 217 - let sorted = List.sort (fun (_, (e1 : weekly_entry)) (_, (e2 : weekly_entry)) -> 218 218 - String.compare e2.week_start e1.week_start) all_entries 255 255 + let sorted = 256 256 + List.sort 257 257 + (fun (_, (e1 : weekly_entry)) (_, (e2 : weekly_entry)) -> 258 258 + String.compare e2.week_start e1.week_start) 259 259 + all_entries 219 260 in 220 261 (* Group by week *) 221 262 let rec group_by_week acc current_week current_group = function 222 263 | [] -> 223 223 - if current_group <> [] then (current_week, List.rev current_group) :: acc 264 264 + if current_group <> [] then 265 265 + (current_week, List.rev current_group) :: acc 224 266 else acc 225 267 | (repo, (entry : weekly_entry)) :: rest -> 226 268 let week_key = entry.week_start ^ " to " ^ entry.week_end in ··· 230 272 group_by_week 231 273 ((current_week, List.rev current_group) :: acc) 232 274 week_key 233 233 - [(repo, entry)] 275 275 + [ (repo, entry) ] 234 276 rest 235 277 in 236 278 let grouped = List.rev (group_by_week [] "" [] sorted) in 237 279 (* Take only the requested number of weeks *) 238 280 let limited = 239 239 - if history > 0 then 240 240 - List.filteri (fun i _ -> i < history) grouped 281 281 + if history > 0 then List.filteri (fun i _ -> i < history) grouped 241 282 else grouped 242 283 in 243 284 (* Generate markdown *) 244 285 let buf = Buffer.create 4096 in 245 286 Buffer.add_string buf "# Changelog\n\n"; 246 246 - List.iter (fun (week_key, entries) -> 247 247 - Buffer.add_string buf (Printf.sprintf "## Week of %s\n\n" week_key); 248 248 - List.iter (fun (repo, (entry : weekly_entry)) -> 249 249 - Buffer.add_string buf (Printf.sprintf "### %s\n" repo); 250 250 - Buffer.add_string buf (Printf.sprintf "%s\n" entry.summary); 251 251 - List.iter (fun change -> 252 252 - Buffer.add_string buf (Printf.sprintf "- %s\n" change)) 253 253 - entry.changes; 254 254 - Buffer.add_string buf "\n") 255 255 - entries) 287 287 + List.iter 288 288 + (fun (week_key, entries) -> 289 289 + Buffer.add_string buf (Printf.sprintf "## Week of %s\n\n" week_key); 290 290 + List.iter 291 291 + (fun (repo, (entry : weekly_entry)) -> 292 292 + Buffer.add_string buf (Printf.sprintf "### %s\n" repo); 293 293 + Buffer.add_string buf (Printf.sprintf "%s\n" entry.summary); 294 294 + List.iter 295 295 + (fun change -> 296 296 + Buffer.add_string buf (Printf.sprintf "- %s\n" change)) 297 297 + entry.changes; 298 298 + Buffer.add_string buf "\n") 299 299 + entries) 256 300 limited; 257 301 Buffer.contents buf 258 302 ··· 266 310 let q = day in 267 311 let k = y mod 100 in 268 312 let j = y / 100 in 269 269 - let h = (q + (13 * (m + 1)) / 5 + k + k / 4 + j / 4 - 2 * j) mod 7 in 313 313 + let h = (q + (13 * (m + 1) / 5) + k + (k / 4) + (j / 4) - (2 * j)) mod 7 in 270 314 (* Convert from Zeller's (0=Sat) to standard (0=Sun) *) 271 271 - ((h + 6) mod 7) 315 315 + (h + 6) mod 7 272 316 273 317 let add_days (y, m, d) n = 274 318 (* Simple day addition - handles month/year boundaries *) ··· 276 320 match month with 277 321 | 1 | 3 | 5 | 7 | 8 | 10 | 12 -> 31 278 322 | 4 | 6 | 9 | 11 -> 30 279 279 - | 2 -> if (year mod 4 = 0 && year mod 100 <> 0) || year mod 400 = 0 then 29 else 28 323 323 + | 2 -> 324 324 + if (year mod 4 = 0 && year mod 100 <> 0) || year mod 400 = 0 then 29 325 325 + else 28 280 326 | _ -> 30 281 327 in 282 328 let rec loop y m d n = ··· 289 335 let new_m = if m = 12 then 1 else m + 1 in 290 336 let new_y = if m = 12 then y + 1 else y in 291 337 loop new_y new_m 1 (n - remaining - 1) 292 292 - else (* n < 0 *) 293 293 - if d + n >= 1 then (y, m, d + n) 294 294 - else 295 295 - let new_m = if m = 1 then 12 else m - 1 in 296 296 - let new_y = if m = 1 then y - 1 else y in 297 297 - let dim = days_in_month new_y new_m in 298 298 - loop new_y new_m dim (n + d) 338 338 + else if 339 339 + (* n < 0 *) 340 340 + d + n >= 1 341 341 + then (y, m, d + n) 342 342 + else 343 343 + let new_m = if m = 1 then 12 else m - 1 in 344 344 + let new_y = if m = 1 then y - 1 else y in 345 345 + let dim = days_in_month new_y new_m in 346 346 + loop new_y new_m dim (n + d) 299 347 in 300 348 loop y m d n 301 349 302 302 - let format_date (y, m, d) = 303 303 - Printf.sprintf "%04d-%02d-%02d" y m d 350 350 + let format_date (y, m, d) = Printf.sprintf "%04d-%02d-%02d" y m d 304 351 305 352 let week_of_date (y, m, d) = 306 353 let dow = day_of_week y m d in ··· 330 377 let aggregate_daily ~history (cfs : daily_changes_file list) = 331 378 (* Collect all entries from all files, tagged with repository *) 332 379 let all_entries = 333 333 - List.concat_map (fun (cf : daily_changes_file) -> 334 334 - List.map (fun (e : daily_entry) -> (cf.repository, e)) cf.entries) 380 380 + List.concat_map 381 381 + (fun (cf : daily_changes_file) -> 382 382 + List.map (fun (e : daily_entry) -> (cf.repository, e)) cf.entries) 335 383 cfs 336 384 in 337 385 (* Sort by date descending *) 338 338 - let sorted = List.sort (fun (_, (e1 : daily_entry)) (_, (e2 : daily_entry)) -> 339 339 - String.compare e2.date e1.date) all_entries 386 386 + let sorted = 387 387 + List.sort 388 388 + (fun (_, (e1 : daily_entry)) (_, (e2 : daily_entry)) -> 389 389 + String.compare e2.date e1.date) 390 390 + all_entries 340 391 in 341 392 (* Group by date *) 342 393 let rec group_by_date acc current_date current_group = function 343 394 | [] -> 344 344 - if current_group <> [] then (current_date, List.rev current_group) :: acc 395 395 + if current_group <> [] then 396 396 + (current_date, List.rev current_group) :: acc 345 397 else acc 346 398 | (repo, (entry : daily_entry)) :: rest -> 347 399 if current_date = "" || current_date = entry.date then ··· 350 402 group_by_date 351 403 ((current_date, List.rev current_group) :: acc) 352 404 entry.date 353 353 - [(repo, entry)] 405 405 + [ (repo, entry) ] 354 406 rest 355 407 in 356 408 let grouped = List.rev (group_by_date [] "" [] sorted) in 357 409 (* Take only the requested number of days *) 358 410 let limited = 359 359 - if history > 0 then 360 360 - List.filteri (fun i _ -> i < history) grouped 411 411 + if history > 0 then List.filteri (fun i _ -> i < history) grouped 361 412 else grouped 362 413 in 363 414 (* Generate markdown - only include repos with actual changes *) 364 415 let buf = Buffer.create 4096 in 365 416 Buffer.add_string buf "# Daily Changelog\n\n"; 366 366 - List.iter (fun (date, entries) -> 367 367 - (* Filter out entries with empty changes - these are repos with no changes *) 368 368 - let entries_with_changes = List.filter (fun (_, (entry : daily_entry)) -> 369 369 - entry.changes <> []) entries 370 370 - in 371 371 - if entries_with_changes <> [] then begin 372 372 - Buffer.add_string buf (Printf.sprintf "## %s\n\n" date); 373 373 - List.iter (fun (repo, (entry : daily_entry)) -> 374 374 - (* Format repo name with link if URL available *) 375 375 - let repo_header = match entry.repo_url with 376 376 - | Some url -> Printf.sprintf "[%s](%s)" repo url 377 377 - | None -> repo 378 378 - in 379 379 - Buffer.add_string buf (Printf.sprintf "### %s\n\n" repo_header); 380 380 - Buffer.add_string buf (Printf.sprintf "%s\n\n" entry.summary); 381 381 - List.iter (fun change -> 382 382 - Buffer.add_string buf (Printf.sprintf "- %s\n" change)) 383 383 - entry.changes; 384 384 - (* Add contributors if any *) 385 385 - if entry.contributors <> [] then begin 386 386 - let contributors_str = String.concat ", " entry.contributors in 387 387 - Buffer.add_string buf (Printf.sprintf "\n*Contributors: %s*\n" contributors_str) 388 388 - end; 389 389 - Buffer.add_string buf "\n") 390 390 - entries_with_changes 391 391 - end) 417 417 + List.iter 418 418 + (fun (date, entries) -> 419 419 + (* Filter out entries with empty changes - these are repos with no changes *) 420 420 + let entries_with_changes = 421 421 + List.filter 422 422 + (fun (_, (entry : daily_entry)) -> entry.changes <> []) 423 423 + entries 424 424 + in 425 425 + if entries_with_changes <> [] then begin 426 426 + Buffer.add_string buf (Printf.sprintf "## %s\n\n" date); 427 427 + List.iter 428 428 + (fun (repo, (entry : daily_entry)) -> 429 429 + (* Format repo name with link if URL available *) 430 430 + let repo_header = 431 431 + match entry.repo_url with 432 432 + | Some url -> Printf.sprintf "[%s](%s)" repo url 433 433 + | None -> repo 434 434 + in 435 435 + Buffer.add_string buf (Printf.sprintf "### %s\n\n" repo_header); 436 436 + Buffer.add_string buf (Printf.sprintf "%s\n\n" entry.summary); 437 437 + List.iter 438 438 + (fun change -> 439 439 + Buffer.add_string buf (Printf.sprintf "- %s\n" change)) 440 440 + entry.changes; 441 441 + (* Add contributors if any *) 442 442 + if entry.contributors <> [] then begin 443 443 + let contributors_str = String.concat ", " entry.contributors in 444 444 + Buffer.add_string buf 445 445 + (Printf.sprintf "\n*Contributors: %s*\n" contributors_str) 446 446 + end; 447 447 + Buffer.add_string buf "\n") 448 448 + entries_with_changes 449 449 + end) 392 450 limited; 393 451 Buffer.contents buf 394 452 ··· 396 454 397 455 let generate_weekly_prompt ~repository ~week_start ~week_end commits = 398 456 let buf = Buffer.create 4096 in 399 399 - Buffer.add_string buf (Printf.sprintf 400 400 - "You are analyzing git commits for the OCaml library \"%s\".\n" repository); 401 401 - Buffer.add_string buf (Printf.sprintf 402 402 - "Generate a user-facing changelog entry for the week of %s to %s.\n\n" 403 403 - week_start week_end); 457 457 + Buffer.add_string buf 458 458 + (Printf.sprintf 459 459 + "You are analyzing git commits for the OCaml library \"%s\".\n" 460 460 + repository); 461 461 + Buffer.add_string buf 462 462 + (Printf.sprintf 463 463 + "Generate a user-facing changelog entry for the week of %s to %s.\n\n" 464 464 + week_start week_end); 404 465 Buffer.add_string buf "## Commits this week:\n\n"; 405 405 - List.iter (fun (commit : Git.log_entry) -> 406 406 - Buffer.add_string buf (Printf.sprintf "### %s by %s (%s)\n" 407 407 - (String.sub commit.hash 0 (min 7 (String.length commit.hash))) 408 408 - commit.author commit.date); 409 409 - Buffer.add_string buf (Printf.sprintf "%s\n\n" commit.subject); 410 410 - if commit.body <> "" then begin 411 411 - Buffer.add_string buf (Printf.sprintf "%s\n" commit.body) 412 412 - end; 413 413 - Buffer.add_string buf "---\n\n") 466 466 + List.iter 467 467 + (fun (commit : Git.log_entry) -> 468 468 + Buffer.add_string buf 469 469 + (Printf.sprintf "### %s by %s (%s)\n" 470 470 + (String.sub commit.hash 0 (min 7 (String.length commit.hash))) 471 471 + commit.author commit.date); 472 472 + Buffer.add_string buf (Printf.sprintf "%s\n\n" commit.subject); 473 473 + if commit.body <> "" then begin 474 474 + Buffer.add_string buf (Printf.sprintf "%s\n" commit.body) 475 475 + end; 476 476 + Buffer.add_string buf "---\n\n") 414 477 commits; 415 415 - Buffer.add_string buf {|## Instructions: 478 478 + Buffer.add_string buf 479 479 + {|## Instructions: 416 480 417 481 1. Focus on USER-FACING changes only. Skip: 418 482 - Internal refactoring with no API impact ··· 445 509 446 510 let generate_daily_prompt ~repository ~date commits = 447 511 let buf = Buffer.create 4096 in 448 448 - Buffer.add_string buf (Printf.sprintf 449 449 - "You are analyzing git commits for the OCaml library \"%s\".\n" repository); 450 450 - Buffer.add_string buf (Printf.sprintf 451 451 - "Generate a user-facing changelog entry for %s.\n\n" date); 512 512 + Buffer.add_string buf 513 513 + (Printf.sprintf 514 514 + "You are analyzing git commits for the OCaml library \"%s\".\n" 515 515 + repository); 516 516 + Buffer.add_string buf 517 517 + (Printf.sprintf "Generate a user-facing changelog entry for %s.\n\n" date); 452 518 Buffer.add_string buf "## Commits today:\n\n"; 453 453 - List.iter (fun (commit : Git.log_entry) -> 454 454 - Buffer.add_string buf (Printf.sprintf "### %s by %s (%s)\n" 455 455 - (String.sub commit.hash 0 (min 7 (String.length commit.hash))) 456 456 - commit.author commit.date); 457 457 - Buffer.add_string buf (Printf.sprintf "%s\n\n" commit.subject); 458 458 - if commit.body <> "" then begin 459 459 - Buffer.add_string buf (Printf.sprintf "%s\n" commit.body) 460 460 - end; 461 461 - Buffer.add_string buf "---\n\n") 519 519 + List.iter 520 520 + (fun (commit : Git.log_entry) -> 521 521 + Buffer.add_string buf 522 522 + (Printf.sprintf "### %s by %s (%s)\n" 523 523 + (String.sub commit.hash 0 (min 7 (String.length commit.hash))) 524 524 + commit.author commit.date); 525 525 + Buffer.add_string buf (Printf.sprintf "%s\n\n" commit.subject); 526 526 + if commit.body <> "" then begin 527 527 + Buffer.add_string buf (Printf.sprintf "%s\n" commit.body) 528 528 + end; 529 529 + Buffer.add_string buf "---\n\n") 462 530 commits; 463 463 - Buffer.add_string buf {|## Instructions: 531 531 + Buffer.add_string buf 532 532 + {|## Instructions: 464 533 465 534 1. Focus on USER-FACING changes only. Skip: 466 535 - Internal refactoring with no API impact ··· 496 565 497 566 (* Response parsing *) 498 567 499 499 - type claude_response = { 500 500 - summary : string; 501 501 - changes : string list; 502 502 - } 568 568 + type claude_response = { summary : string; changes : string list } 503 569 504 570 let claude_response_jsont = 505 571 let make summary changes = { summary; changes } in 506 572 Jsont.Object.map ~kind:"claude_response" make 507 573 |> Jsont.Object.mem "summary" Jsont.string ~enc:(fun r -> r.summary) 508 508 - |> Jsont.Object.mem "changes" (Jsont.list Jsont.string) ~enc:(fun r -> r.changes) 574 574 + |> Jsont.Object.mem "changes" (Jsont.list Jsont.string) ~enc:(fun r -> 575 575 + r.changes) 509 576 |> Jsont.Object.finish 510 577 511 578 let parse_claude_response text = ··· 516 583 match Jsont_bytesrw.decode_string claude_response_jsont text with 517 584 | Ok r -> 518 585 (* Treat empty summary and changes as no changes *) 519 519 - if r.summary = "" && r.changes = [] then Ok None 520 520 - else Ok (Some r) 586 586 + if r.summary = "" && r.changes = [] then Ok None else Ok (Some r) 521 587 | Error e -> Error (Format.sprintf "Failed to parse Claude response: %s" e) 522 588 523 589 (* Main analysis function *) 524 590 525 525 - let analyze_commits 526 526 - ~sw 527 527 - ~process_mgr 528 528 - ~clock 529 529 - ~repository 530 530 - ~week_start 531 531 - ~week_end 591 591 + let analyze_commits ~sw ~process_mgr ~clock ~repository ~week_start ~week_end 532 592 commits = 533 593 if commits = [] then Ok None 534 594 else begin ··· 537 597 (* Create Claude options with structured output *) 538 598 let output_schema = 539 599 let open Jsont in 540 540 - Object ([ 541 541 - (("type", Meta.none), String ("object", Meta.none)); 542 542 - (("properties", Meta.none), Object ([ 543 543 - (("summary", Meta.none), Object ([ 544 544 - (("type", Meta.none), String ("string", Meta.none)); 545 545 - ], Meta.none)); 546 546 - (("changes", Meta.none), Object ([ 547 547 - (("type", Meta.none), String ("array", Meta.none)); 548 548 - (("items", Meta.none), Object ([ 549 549 - (("type", Meta.none), String ("string", Meta.none)); 550 550 - ], Meta.none)); 551 551 - ], Meta.none)); 552 552 - ], Meta.none)); 553 553 - (("required", Meta.none), Array ([ 554 554 - String ("summary", Meta.none); 555 555 - String ("changes", Meta.none); 556 556 - ], Meta.none)); 557 557 - ], Meta.none) 600 600 + Object 601 601 + ( [ 602 602 + (("type", Meta.none), String ("object", Meta.none)); 603 603 + ( ("properties", Meta.none), 604 604 + Object 605 605 + ( [ 606 606 + ( ("summary", Meta.none), 607 607 + Object 608 608 + ( [ (("type", Meta.none), String ("string", Meta.none)) ], 609 609 + Meta.none ) ); 610 610 + ( ("changes", Meta.none), 611 611 + Object 612 612 + ( [ 613 613 + (("type", Meta.none), String ("array", Meta.none)); 614 614 + ( ("items", Meta.none), 615 615 + Object 616 616 + ( [ 617 617 + ( ("type", Meta.none), 618 618 + String ("string", Meta.none) ); 619 619 + ], 620 620 + Meta.none ) ); 621 621 + ], 622 622 + Meta.none ) ); 623 623 + ], 624 624 + Meta.none ) ); 625 625 + ( ("required", Meta.none), 626 626 + Array 627 627 + ( [ 628 628 + String ("summary", Meta.none); String ("changes", Meta.none); 629 629 + ], 630 630 + Meta.none ) ); 631 631 + ], 632 632 + Meta.none ) 558 633 in 559 559 - let output_format = Claude.Proto.Structured_output.of_json_schema output_schema in 634 634 + let output_format = 635 635 + Claude.Proto.Structured_output.of_json_schema output_schema 636 636 + in 560 637 let options = 561 638 Claude.Options.default 562 639 |> Claude.Options.with_output_format output_format ··· 568 645 569 646 let responses = Claude.Client.receive_all client in 570 647 let result = ref None in 571 571 - List.iter (function 572 572 - | Claude.Response.Complete c -> ( 573 573 - match Claude.Response.Complete.structured_output c with 574 574 - | Some json -> ( 575 575 - match Jsont.Json.decode claude_response_jsont json with 576 576 - | Ok r -> result := Some (Ok (Some r)) 577 577 - | Error e -> 578 578 - result := Some (Error (Format.sprintf "Failed to decode response: %s" e))) 579 579 - | None -> 580 580 - (* Try to get text and parse it as fallback *) 581 581 - match Claude.Response.Complete.result_text c with 582 582 - | Some text -> result := Some (parse_claude_response text) 583 583 - | None -> result := Some (Ok None)) 584 584 - | Claude.Response.Text t -> 585 585 - let text = Claude.Response.Text.content t in 586 586 - if String.trim text = "NO_CHANGES" then 587 587 - result := Some (Ok None) 588 588 - | Claude.Response.Error e -> 589 589 - result := Some (Error (Printf.sprintf "Claude error: %s" (Claude.Response.Error.message e))) 590 590 - | _ -> ()) 648 648 + List.iter 649 649 + (function 650 650 + | Claude.Response.Complete c -> ( 651 651 + match Claude.Response.Complete.structured_output c with 652 652 + | Some json -> ( 653 653 + match Jsont.Json.decode claude_response_jsont json with 654 654 + | Ok r -> result := Some (Ok (Some r)) 655 655 + | Error e -> 656 656 + result := 657 657 + Some 658 658 + (Error 659 659 + (Format.sprintf "Failed to decode response: %s" e))) 660 660 + | None -> ( 661 661 + (* Try to get text and parse it as fallback *) 662 662 + match Claude.Response.Complete.result_text c with 663 663 + | Some text -> result := Some (parse_claude_response text) 664 664 + | None -> result := Some (Ok None))) 665 665 + | Claude.Response.Text t -> 666 666 + let text = Claude.Response.Text.content t in 667 667 + if String.trim text = "NO_CHANGES" then result := Some (Ok None) 668 668 + | Claude.Response.Error e -> 669 669 + result := 670 670 + Some 671 671 + (Error 672 672 + (Printf.sprintf "Claude error: %s" 673 673 + (Claude.Response.Error.message e))) 674 674 + | _ -> ()) 591 675 responses; 592 676 593 593 - match !result with 594 594 - | Some r -> r 595 595 - | None -> Ok None 677 677 + match !result with Some r -> r | None -> Ok None 596 678 end 597 679 598 680 (* Daily analysis function *) 599 599 - let analyze_commits_daily 600 600 - ~sw 601 601 - ~process_mgr 602 602 - ~clock 603 603 - ~repository 604 604 - ~date 605 605 - commits = 681 681 + let analyze_commits_daily ~sw ~process_mgr ~clock ~repository ~date commits = 606 682 if commits = [] then Ok None 607 683 else begin 608 684 let prompt = generate_daily_prompt ~repository ~date commits in ··· 610 686 (* Create Claude options with structured output *) 611 687 let output_schema = 612 688 let open Jsont in 613 613 - Object ([ 614 614 - (("type", Meta.none), String ("object", Meta.none)); 615 615 - (("properties", Meta.none), Object ([ 616 616 - (("summary", Meta.none), Object ([ 617 617 - (("type", Meta.none), String ("string", Meta.none)); 618 618 - ], Meta.none)); 619 619 - (("changes", Meta.none), Object ([ 620 620 - (("type", Meta.none), String ("array", Meta.none)); 621 621 - (("items", Meta.none), Object ([ 622 622 - (("type", Meta.none), String ("string", Meta.none)); 623 623 - ], Meta.none)); 624 624 - ], Meta.none)); 625 625 - ], Meta.none)); 626 626 - (("required", Meta.none), Array ([ 627 627 - String ("summary", Meta.none); 628 628 - String ("changes", Meta.none); 629 629 - ], Meta.none)); 630 630 - ], Meta.none) 689 689 + Object 690 690 + ( [ 691 691 + (("type", Meta.none), String ("object", Meta.none)); 692 692 + ( ("properties", Meta.none), 693 693 + Object 694 694 + ( [ 695 695 + ( ("summary", Meta.none), 696 696 + Object 697 697 + ( [ (("type", Meta.none), String ("string", Meta.none)) ], 698 698 + Meta.none ) ); 699 699 + ( ("changes", Meta.none), 700 700 + Object 701 701 + ( [ 702 702 + (("type", Meta.none), String ("array", Meta.none)); 703 703 + ( ("items", Meta.none), 704 704 + Object 705 705 + ( [ 706 706 + ( ("type", Meta.none), 707 707 + String ("string", Meta.none) ); 708 708 + ], 709 709 + Meta.none ) ); 710 710 + ], 711 711 + Meta.none ) ); 712 712 + ], 713 713 + Meta.none ) ); 714 714 + ( ("required", Meta.none), 715 715 + Array 716 716 + ( [ 717 717 + String ("summary", Meta.none); String ("changes", Meta.none); 718 718 + ], 719 719 + Meta.none ) ); 720 720 + ], 721 721 + Meta.none ) 722 722 + in 723 723 + let output_format = 724 724 + Claude.Proto.Structured_output.of_json_schema output_schema 631 725 in 632 632 - let output_format = Claude.Proto.Structured_output.of_json_schema output_schema in 633 726 let options = 634 727 Claude.Options.default 635 728 |> Claude.Options.with_output_format output_format ··· 641 734 642 735 let responses = Claude.Client.receive_all client in 643 736 let result = ref None in 644 644 - List.iter (function 645 645 - | Claude.Response.Complete c -> ( 646 646 - match Claude.Response.Complete.structured_output c with 647 647 - | Some json -> ( 648 648 - match Jsont.Json.decode claude_response_jsont json with 649 649 - | Ok r -> 650 650 - (* Treat empty response as no changes *) 651 651 - if r.summary = "" && r.changes = [] then 652 652 - result := Some (Ok None) 653 653 - else 654 654 - result := Some (Ok (Some r)) 655 655 - | Error e -> 656 656 - result := Some (Error (Format.sprintf "Failed to decode response: %s" e))) 657 657 - | None -> 658 658 - (* Try to get text and parse it as fallback *) 659 659 - match Claude.Response.Complete.result_text c with 660 660 - | Some text -> result := Some (parse_claude_response text) 661 661 - | None -> result := Some (Ok None)) 662 662 - | Claude.Response.Text t -> 663 663 - let text = Claude.Response.Text.content t in 664 664 - if String.trim text = "NO_CHANGES" then 665 665 - result := Some (Ok None) 666 666 - | Claude.Response.Error e -> 667 667 - result := Some (Error (Printf.sprintf "Claude error: %s" (Claude.Response.Error.message e))) 668 668 - | _ -> ()) 737 737 + List.iter 738 738 + (function 739 739 + | Claude.Response.Complete c -> ( 740 740 + match Claude.Response.Complete.structured_output c with 741 741 + | Some json -> ( 742 742 + match Jsont.Json.decode claude_response_jsont json with 743 743 + | Ok r -> 744 744 + (* Treat empty response as no changes *) 745 745 + if r.summary = "" && r.changes = [] then 746 746 + result := Some (Ok None) 747 747 + else result := Some (Ok (Some r)) 748 748 + | Error e -> 749 749 + result := 750 750 + Some 751 751 + (Error 752 752 + (Format.sprintf "Failed to decode response: %s" e))) 753 753 + | None -> ( 754 754 + (* Try to get text and parse it as fallback *) 755 755 + match Claude.Response.Complete.result_text c with 756 756 + | Some text -> result := Some (parse_claude_response text) 757 757 + | None -> result := Some (Ok None))) 758 758 + | Claude.Response.Text t -> 759 759 + let text = Claude.Response.Text.content t in 760 760 + if String.trim text = "NO_CHANGES" then result := Some (Ok None) 761 761 + | Claude.Response.Error e -> 762 762 + result := 763 763 + Some 764 764 + (Error 765 765 + (Printf.sprintf "Claude error: %s" 766 766 + (Claude.Response.Error.message e))) 767 767 + | _ -> ()) 669 768 responses; 670 769 671 671 - match !result with 672 672 - | Some r -> r 673 673 - | None -> Ok None 770 770 + match !result with Some r -> r | None -> Ok None 674 771 end 675 772 676 773 (* Refine daily changelog markdown to be more narrative *) 677 677 - let refine_daily_changelog 678 678 - ~sw 679 679 - ~process_mgr 680 680 - ~clock 681 681 - markdown = 682 682 - let prompt = Printf.sprintf {|You are editing a daily changelog for an OCaml monorepo. 774 774 + let refine_daily_changelog ~sw ~process_mgr ~clock markdown = 775 775 + let prompt = 776 776 + Printf.sprintf 777 777 + {|You are editing a daily changelog for an OCaml monorepo. 683 778 684 779 Your task is to refine the following changelog to be: 685 780 1. More narrative and human-readable - write it as a daily update that developers will want to read ··· 705 800 706 801 %s 707 802 708 708 - Output ONLY the refined markdown, no explanation or preamble.|} markdown 803 803 + Output ONLY the refined markdown, no explanation or preamble.|} 804 804 + markdown 709 805 in 710 806 711 711 - let options = 712 712 - Claude.Options.default 713 713 - |> Claude.Options.with_max_turns 1 714 714 - in 807 807 + let options = Claude.Options.default |> Claude.Options.with_max_turns 1 in 715 808 716 809 let client = Claude.Client.create ~sw ~process_mgr ~clock ~options () in 717 810 Claude.Client.query client prompt; 718 811 719 812 let responses = Claude.Client.receive_all client in 720 813 let result = ref None in 721 721 - List.iter (function 722 722 - | Claude.Response.Complete c -> ( 723 723 - match Claude.Response.Complete.result_text c with 724 724 - | Some text -> result := Some (Ok text) 725 725 - | None -> result := Some (Ok markdown)) (* fallback to original *) 726 726 - | Claude.Response.Error e -> 727 727 - result := Some (Error (Printf.sprintf "Claude error: %s" (Claude.Response.Error.message e))) 728 728 - | _ -> ()) 814 814 + List.iter 815 815 + (function 816 816 + | Claude.Response.Complete c -> ( 817 817 + match Claude.Response.Complete.result_text c with 818 818 + | Some text -> result := Some (Ok text) 819 819 + | None -> result := Some (Ok markdown) (* fallback to original *)) 820 820 + | Claude.Response.Error e -> 821 821 + result := 822 822 + Some 823 823 + (Error 824 824 + (Printf.sprintf "Claude error: %s" 825 825 + (Claude.Response.Error.message e))) 826 826 + | _ -> ()) 729 827 responses; 730 828 731 829 match !result with ··· 749 847 (* Infer change type from summary text *) 750 848 let infer_change_type summary = 751 849 let summary_lower = String.lowercase_ascii summary in 752 752 - if String.starts_with ~prefix:"initial import" summary_lower || 753 753 - String.starts_with ~prefix:"added as subtree" summary_lower || 754 754 - String.starts_with ~prefix:"added" summary_lower && String.ends_with ~suffix:"library" summary_lower then 755 755 - Changes_aggregated.New_library 756 756 - else if List.exists (fun kw -> string_contains_s summary_lower kw) 757 757 - ["fix"; "bugfix"; "bug fix"; "repair"; "patch"; "resolve"; "correct"] then 758 758 - Changes_aggregated.Bugfix 759 759 - else if List.exists (fun kw -> string_contains_s summary_lower kw) 760 760 - ["refactor"; "cleanup"; "clean up"; "reorganize"; "restructure"; "simplify"] then 761 761 - Changes_aggregated.Refactor 762 762 - else if List.exists (fun kw -> string_contains_s summary_lower kw) 763 763 - ["doc"; "documentation"; "readme"; "comment"; "tutorial"; "guide"] then 764 764 - Changes_aggregated.Documentation 765 765 - else if List.exists (fun kw -> string_contains_s summary_lower kw) 766 766 - ["add"; "new"; "feature"; "implement"; "support"; "introduce"; "enable"] then 767 767 - Changes_aggregated.Feature 768 768 - else 769 769 - Changes_aggregated.Unknown 850 850 + if 851 851 + String.starts_with ~prefix:"initial import" summary_lower 852 852 + || String.starts_with ~prefix:"added as subtree" summary_lower 853 853 + || String.starts_with ~prefix:"added" summary_lower 854 854 + && String.ends_with ~suffix:"library" summary_lower 855 855 + then Changes_aggregated.New_library 856 856 + else if 857 857 + List.exists 858 858 + (fun kw -> string_contains_s summary_lower kw) 859 859 + [ "fix"; "bugfix"; "bug fix"; "repair"; "patch"; "resolve"; "correct" ] 860 860 + then Changes_aggregated.Bugfix 861 861 + else if 862 862 + List.exists 863 863 + (fun kw -> string_contains_s summary_lower kw) 864 864 + [ 865 865 + "refactor"; 866 866 + "cleanup"; 867 867 + "clean up"; 868 868 + "reorganize"; 869 869 + "restructure"; 870 870 + "simplify"; 871 871 + ] 872 872 + then Changes_aggregated.Refactor 873 873 + else if 874 874 + List.exists 875 875 + (fun kw -> string_contains_s summary_lower kw) 876 876 + [ "doc"; "documentation"; "readme"; "comment"; "tutorial"; "guide" ] 877 877 + then Changes_aggregated.Documentation 878 878 + else if 879 879 + List.exists 880 880 + (fun kw -> string_contains_s summary_lower kw) 881 881 + [ "add"; "new"; "feature"; "implement"; "support"; "introduce"; "enable" ] 882 882 + then Changes_aggregated.Feature 883 883 + else Changes_aggregated.Unknown 770 884 771 771 - (** Generate an aggregated daily file from individual daily json files. 772 772 - This creates a YYYYMMDD.json file in the .changes directory. *) 885 885 + (** Generate an aggregated daily file from individual daily json files. This 886 886 + creates a YYYYMMDD.json file in the .changes directory. *) 773 887 let generate_aggregated ~fs ~monorepo ~date ~git_head ~now = 774 888 let changes_dir = Eio.Path.(fs / Fpath.to_string monorepo / ".changes") in 775 889 776 890 (* List all *-<date>.json files (new per-day format) *) 777 777 - let files = 778 778 - try Eio.Path.read_dir changes_dir 779 779 - with Eio.Io _ -> [] 780 780 - in 891 891 + let files = try Eio.Path.read_dir changes_dir with Eio.Io _ -> [] in 781 892 (* Match files like "<repo>-2026-01-19.json" for the given date *) 782 893 let date_suffix = "-" ^ date ^ ".json" in 783 894 let date_suffix_len = String.length date_suffix in 784 784 - let daily_files = List.filter (fun f -> 785 785 - String.ends_with ~suffix:date_suffix f && String.length f > date_suffix_len) files 895 895 + let daily_files = 896 896 + List.filter 897 897 + (fun f -> 898 898 + String.ends_with ~suffix:date_suffix f 899 899 + && String.length f > date_suffix_len) 900 900 + files 786 901 in 787 902 788 903 (* Load all daily files for this date and collect entries *) 789 789 - let entries = List.concat_map (fun filename -> 790 790 - (* Extract repo name: filename is "<repo>-<date>.json" *) 791 791 - let repo_name = String.sub filename 0 (String.length filename - date_suffix_len) in 792 792 - let path = Eio.Path.(changes_dir / filename) in 793 793 - try 794 794 - let content = Eio.Path.load path in 795 795 - match Jsont_bytesrw.decode_string daily_changes_file_jsont content with 796 796 - | Ok dcf -> 797 797 - List.filter_map (fun (e : daily_entry) -> 798 798 - if e.changes <> [] then 799 799 - Some (repo_name, e) 800 800 - else 801 801 - None) dcf.entries 802 802 - | Error _ -> [] 803 803 - with Eio.Io _ -> [] 804 804 - ) daily_files in 904 904 + let entries = 905 905 + List.concat_map 906 906 + (fun filename -> 907 907 + (* Extract repo name: filename is "<repo>-<date>.json" *) 908 908 + let repo_name = 909 909 + String.sub filename 0 (String.length filename - date_suffix_len) 910 910 + in 911 911 + let path = Eio.Path.(changes_dir / filename) in 912 912 + try 913 913 + let content = Eio.Path.load path in 914 914 + match 915 915 + Jsont_bytesrw.decode_string daily_changes_file_jsont content 916 916 + with 917 917 + | Ok dcf -> 918 918 + List.filter_map 919 919 + (fun (e : daily_entry) -> 920 920 + if e.changes <> [] then Some (repo_name, e) else None) 921 921 + dcf.entries 922 922 + | Error _ -> [] 923 923 + with Eio.Io _ -> []) 924 924 + daily_files 925 925 + in 805 926 806 927 (* Convert to aggregated format *) 807 807 - let agg_entries = List.map (fun (repo_name, (e : daily_entry)) -> 808 808 - let change_type = infer_change_type e.summary in 809 809 - Changes_aggregated.{ 810 810 - repository = repo_name; 811 811 - hour = e.hour; 812 812 - timestamp = e.timestamp; 813 813 - summary = e.summary; 814 814 - changes = e.changes; 815 815 - commit_range = { 816 816 - from_hash = e.commit_range.from_hash; 817 817 - to_hash = e.commit_range.to_hash; 818 818 - count = e.commit_range.count; 819 819 - }; 820 820 - contributors = e.contributors; 821 821 - repo_url = e.repo_url; 822 822 - change_type; 823 823 - }) entries 928 928 + let agg_entries = 929 929 + List.map 930 930 + (fun (repo_name, (e : daily_entry)) -> 931 931 + let change_type = infer_change_type e.summary in 932 932 + Changes_aggregated. 933 933 + { 934 934 + repository = repo_name; 935 935 + hour = e.hour; 936 936 + timestamp = e.timestamp; 937 937 + summary = e.summary; 938 938 + changes = e.changes; 939 939 + commit_range = 940 940 + { 941 941 + from_hash = e.commit_range.from_hash; 942 942 + to_hash = e.commit_range.to_hash; 943 943 + count = e.commit_range.count; 944 944 + }; 945 945 + contributors = e.contributors; 946 946 + repo_url = e.repo_url; 947 947 + change_type; 948 948 + }) 949 949 + entries 824 950 in 825 951 826 952 (* Collect all unique authors *) ··· 831 957 in 832 958 833 959 (* Create the aggregated structure *) 834 834 - let aggregated : Changes_aggregated.t = { 835 835 - date; 836 836 - generated_at = now; 837 837 - git_head; 838 838 - entries = agg_entries; 839 839 - authors; 840 840 - } in 960 960 + let aggregated : Changes_aggregated.t = 961 961 + { date; generated_at = now; git_head; entries = agg_entries; authors } 962 962 + in 841 963 842 964 (* Save to YYYYMMDD.json *) 843 965 let changes_dir_fpath = Fpath.(v (Fpath.to_string monorepo) / ".changes") in

+90 -78

lib/changes.mli

reviewed

··· 1 1 (** Changelog generation for monopam. 2 2 3 3 - This module handles generating weekly and daily changelog entries using Claude AI 4 4 - to analyze git commit history and produce user-facing change summaries. 3 3 + This module handles generating weekly and daily changelog entries using 4 4 + Claude AI to analyze git commit history and produce user-facing change 5 5 + summaries. 5 6 6 7 Changes are stored in a .changes directory at the monorepo root: 7 8 - .changes/<repo_name>.json - weekly changelog entries 8 8 - - .changes/<repo_name>-<YYYY-MM-DD>.json - daily changelog entries (one file per day per repo) 9 9 + - .changes/<repo_name>-<YYYY-MM-DD>.json - daily changelog entries (one file 10 10 + per day per repo) 9 11 - .changes/YYYYMMDD.json - aggregated daily changes for broadcasting 10 12 11 13 {1 Submodules} 12 14 13 13 - These modules provide types and I/O for querying the generated changes files. *) 15 15 + These modules provide types and I/O for querying the generated changes 16 16 + files. *) 14 17 15 15 - (** Aggregated daily changes format (YYYYMMDD.json files). *) 16 18 module Aggregated = Changes_aggregated 19 19 + (** Aggregated daily changes format (YYYYMMDD.json files). *) 17 20 18 18 - (** Daily changes with per-day-per-repo structure (repo-YYYY-MM-DD.json files). *) 19 21 module Daily = Changes_daily 22 22 + (** Daily changes with per-day-per-repo structure (repo-YYYY-MM-DD.json files). 23 23 + *) 20 24 21 21 - (** High-level query interface for changes. *) 22 25 module Query = Changes_query 26 26 + (** High-level query interface for changes. *) 23 27 24 28 (** {1 Types} *) 25 29 26 26 - type commit_range = { 27 27 - from_hash : string; 28 28 - to_hash : string; 29 29 - count : int; 30 30 - } 30 30 + type commit_range = { from_hash : string; to_hash : string; count : int } 31 31 (** Range of commits included in a changelog entry. *) 32 32 33 33 type weekly_entry = { 34 34 week_start : string; (** ISO date YYYY-MM-DD, Monday *) 35 35 - week_end : string; (** ISO date YYYY-MM-DD, Sunday *) 36 36 - summary : string; (** One-line summary *) 37 37 - changes : string list; (** Bullet points *) 35 35 + week_end : string; (** ISO date YYYY-MM-DD, Sunday *) 36 36 + summary : string; (** One-line summary *) 37 37 + changes : string list; (** Bullet points *) 38 38 commit_range : commit_range; 39 39 } 40 40 (** A single week's changelog entry. *) 41 41 42 42 type daily_entry = { 43 43 - date : string; (** ISO date YYYY-MM-DD *) 44 44 - hour : int; (** Hour of day 0-23 for filtering *) 43 43 + date : string; (** ISO date YYYY-MM-DD *) 44 44 + hour : int; (** Hour of day 0-23 for filtering *) 45 45 timestamp : Ptime.t; (** RFC3339 timestamp for precise ordering *) 46 46 - summary : string; (** One-line summary *) 47 47 - changes : string list; (** Bullet points *) 46 46 + summary : string; (** One-line summary *) 47 47 + changes : string list; (** Bullet points *) 48 48 commit_range : commit_range; 49 49 - contributors : string list; (** List of contributors for this entry *) 50 50 - repo_url : string option; (** Upstream repository URL *) 49 49 + contributors : string list; (** List of contributors for this entry *) 50 50 + repo_url : string option; (** Upstream repository URL *) 51 51 } 52 52 (** A single day's changelog entry with hour tracking for real-time updates. *) 53 53 54 54 - type changes_file = { 55 55 - repository : string; 56 56 - entries : weekly_entry list; 57 57 - } 54 54 + type changes_file = { repository : string; entries : weekly_entry list } 58 55 (** Contents of a weekly changes JSON file for a repository. *) 59 56 60 60 - type daily_changes_file = { 61 61 - repository : string; 62 62 - entries : daily_entry list; 63 63 - } 57 57 + type daily_changes_file = { repository : string; entries : daily_entry list } 64 58 (** Contents of a daily changes JSON file for a repository. *) 65 59 66 60 (** Mode for changelog generation. *) ··· 85 79 86 80 (** {1 File I/O} *) 87 81 88 88 - val load : fs:_ Eio.Path.t -> monorepo:Fpath.t -> string -> (changes_file, string) result 89 89 - (** [load ~fs ~monorepo repo_name] loads weekly changes from .changes/<repo_name>.json. 90 90 - Returns an empty changes file if the file does not exist. *) 82 82 + val load : 83 83 + fs:_ Eio.Path.t -> monorepo:Fpath.t -> string -> (changes_file, string) result 84 84 + (** [load ~fs ~monorepo repo_name] loads weekly changes from 85 85 + .changes/<repo_name>.json. Returns an empty changes file if the file does 86 86 + not exist. *) 91 87 92 92 - val save : fs:_ Eio.Path.t -> monorepo:Fpath.t -> changes_file -> (unit, string) result 93 93 - (** [save ~fs ~monorepo cf] saves the changes file to .changes/<repo_name>.json. *) 88 88 + val save : 89 89 + fs:_ Eio.Path.t -> monorepo:Fpath.t -> changes_file -> (unit, string) result 90 90 + (** [save ~fs ~monorepo cf] saves the changes file to .changes/<repo_name>.json. 91 91 + *) 94 92 95 95 - val daily_exists : fs:_ Eio.Path.t -> monorepo:Fpath.t -> date:string -> string -> bool 96 96 - (** [daily_exists ~fs ~monorepo ~date repo_name] checks if a daily changes file exists. 93 93 + val daily_exists : 94 94 + fs:_ Eio.Path.t -> monorepo:Fpath.t -> date:string -> string -> bool 95 95 + (** [daily_exists ~fs ~monorepo ~date repo_name] checks if a daily changes file 96 96 + exists. 97 97 @param date Date in YYYY-MM-DD format *) 98 98 99 99 - val load_daily : fs:_ Eio.Path.t -> monorepo:Fpath.t -> date:string -> string -> (daily_changes_file, string) result 100 100 - (** [load_daily ~fs ~monorepo ~date repo_name] loads daily changes from .changes/<repo_name>-<date>.json. 101 101 - Returns an empty changes file if the file does not exist. 99 99 + val load_daily : 100 100 + fs:_ Eio.Path.t -> 101 101 + monorepo:Fpath.t -> 102 102 + date:string -> 103 103 + string -> 104 104 + (daily_changes_file, string) result 105 105 + (** [load_daily ~fs ~monorepo ~date repo_name] loads daily changes from 106 106 + .changes/<repo_name>-<date>.json. Returns an empty changes file if the file 107 107 + does not exist. 102 108 @param date Date in YYYY-MM-DD format *) 103 109 104 104 - val save_daily : fs:_ Eio.Path.t -> monorepo:Fpath.t -> date:string -> daily_changes_file -> (unit, string) result 105 105 - (** [save_daily ~fs ~monorepo ~date cf] saves the changes file to .changes/<repo_name>-<date>.json. 110 110 + val save_daily : 111 111 + fs:_ Eio.Path.t -> 112 112 + monorepo:Fpath.t -> 113 113 + date:string -> 114 114 + daily_changes_file -> 115 115 + (unit, string) result 116 116 + (** [save_daily ~fs ~monorepo ~date cf] saves the changes file to 117 117 + .changes/<repo_name>-<date>.json. 106 118 @param date Date in YYYY-MM-DD format *) 107 119 108 120 (** {1 Markdown Generation} *) ··· 111 123 (** [to_markdown cf] generates markdown from a single weekly changes file. *) 112 124 113 125 val aggregate : history:int -> changes_file list -> string 114 114 - (** [aggregate ~history cfs] generates combined markdown from multiple weekly changes files. 126 126 + (** [aggregate ~history cfs] generates combined markdown from multiple weekly 127 127 + changes files. 115 128 @param history Number of weeks to include (0 for all) *) 116 129 117 130 val aggregate_daily : history:int -> daily_changes_file list -> string 118 118 - (** [aggregate_daily ~history cfs] generates combined markdown from multiple daily changes files. 119 119 - Only includes repos with actual changes (filters out empty entries). 131 131 + (** [aggregate_daily ~history cfs] generates combined markdown from multiple 132 132 + daily changes files. Only includes repos with actual changes (filters out 133 133 + empty entries). 120 134 @param history Number of days to include (0 for all) *) 121 135 122 136 (** {1 Date Calculation} *) ··· 125 139 (** [format_date (year, month, day)] formats a date as YYYY-MM-DD. *) 126 140 127 141 val week_of_date : int * int * int -> string * string 128 128 - (** [week_of_date (year, month, day)] returns (week_start, week_end) as ISO date strings. 129 129 - week_start is Monday, week_end is Sunday. *) 142 142 + (** [week_of_date (year, month, day)] returns (week_start, week_end) as ISO date 143 143 + strings. week_start is Monday, week_end is Sunday. *) 130 144 131 145 val week_of_ptime : Ptime.t -> string * string 132 146 (** [week_of_ptime t] returns (week_start, week_end) for the given timestamp. *) ··· 135 149 (** [date_of_ptime t] returns the date as YYYY-MM-DD for the given timestamp. *) 136 150 137 151 val has_week : changes_file -> week_start:string -> bool 138 138 - (** [has_week cf ~week_start] returns true if the changes file already has an entry 139 139 - for the week starting on the given date. *) 152 152 + (** [has_week cf ~week_start] returns true if the changes file already has an 153 153 + entry for the week starting on the given date. *) 140 154 141 155 val has_day : daily_changes_file -> date:string -> bool 142 142 - (** [has_day cf ~date] returns true if the daily changes file already has an entry 143 143 - for the given date. *) 156 156 + (** [has_day cf ~date] returns true if the daily changes file already has an 157 157 + entry for the given date. *) 144 158 145 159 (** {1 Claude Integration} *) 146 160 147 147 - type claude_response = { 148 148 - summary : string; 149 149 - changes : string list; 150 150 - } 161 161 + type claude_response = { summary : string; changes : string list } 151 162 (** Response from Claude analysis. *) 152 163 153 164 val generate_prompt : ··· 156 167 week_end:string -> 157 168 Git.log_entry list -> 158 169 string 159 159 - (** [generate_prompt ~repository ~week_start ~week_end commits] creates the prompt 160 160 - to send to Claude for weekly changelog generation. *) 170 170 + (** [generate_prompt ~repository ~week_start ~week_end commits] creates the 171 171 + prompt to send to Claude for weekly changelog generation. *) 161 172 162 173 val generate_weekly_prompt : 163 174 repository:string -> ··· 165 176 week_end:string -> 166 177 Git.log_entry list -> 167 178 string 168 168 - (** [generate_weekly_prompt ~repository ~week_start ~week_end commits] creates the prompt 169 169 - to send to Claude for weekly changelog generation. *) 179 179 + (** [generate_weekly_prompt ~repository ~week_start ~week_end commits] creates 180 180 + the prompt to send to Claude for weekly changelog generation. *) 170 181 171 182 val generate_daily_prompt : 172 172 - repository:string -> 173 173 - date:string -> 174 174 - Git.log_entry list -> 175 175 - string 176 176 - (** [generate_daily_prompt ~repository ~date commits] creates the prompt 177 177 - to send to Claude for daily changelog generation. *) 183 183 + repository:string -> date:string -> Git.log_entry list -> string 184 184 + (** [generate_daily_prompt ~repository ~date commits] creates the prompt to send 185 185 + to Claude for daily changelog generation. *) 178 186 179 187 val parse_claude_response : string -> (claude_response option, string) result 180 180 - (** [parse_claude_response text] parses Claude's response. 181 181 - Returns [Ok None] if the response is empty (blank summary and changes) or "NO_CHANGES". 182 182 - Returns [Ok (Some r)] if valid JSON was parsed with actual changes. 183 183 - Returns [Error msg] if parsing failed. *) 188 188 + (** [parse_claude_response text] parses Claude's response. Returns [Ok None] if 189 189 + the response is empty (blank summary and changes) or "NO_CHANGES". Returns 190 190 + [Ok (Some r)] if valid JSON was parsed with actual changes. Returns 191 191 + [Error msg] if parsing failed. *) 184 192 185 193 val analyze_commits : 186 194 sw:Eio.Switch.t -> ··· 191 199 week_end:string -> 192 200 Git.log_entry list -> 193 201 (claude_response option, string) result 194 194 - (** [analyze_commits ~sw ~process_mgr ~clock ~repository ~week_start ~week_end commits] 195 195 - sends commits to Claude for weekly analysis and returns the parsed response. *) 202 202 + (** [analyze_commits ~sw ~process_mgr ~clock ~repository ~week_start ~week_end 203 203 + commits] sends commits to Claude for weekly analysis and returns the parsed 204 204 + response. *) 196 205 197 206 val analyze_commits_daily : 198 207 sw:Eio.Switch.t -> ··· 203 212 Git.log_entry list -> 204 213 (claude_response option, string) result 205 214 (** [analyze_commits_daily ~sw ~process_mgr ~clock ~repository ~date commits] 206 206 - sends commits to Claude for daily analysis and returns the parsed response. *) 215 215 + sends commits to Claude for daily analysis and returns the parsed response. 216 216 + *) 207 217 208 218 val refine_daily_changelog : 209 219 sw:Eio.Switch.t -> ··· 213 223 (string, string) result 214 224 (** [refine_daily_changelog ~sw ~process_mgr ~clock markdown] sends the raw 215 225 daily changelog markdown through Claude to produce a more narrative, 216 216 - well-organized version. Groups related changes together and orders them 217 217 - by significance. Ensures all repository names are formatted as markdown 218 218 - links using the pattern [\[repo-name\](https://tangled.org/@anil.recoil.org/repo-name.git)]. 219 219 - Returns the refined markdown or the original on error. *) 226 226 + well-organized version. Groups related changes together and orders them by 227 227 + significance. Ensures all repository names are formatted as markdown links 228 228 + using the pattern 229 229 + [[repo-name](https://tangled.org/@anil.recoil.org/repo-name.git)]. Returns 230 230 + the refined markdown or the original on error. *) 220 231 221 232 (** {1 Aggregated Files} *) 222 233 ··· 227 238 git_head:string -> 228 239 now:Ptime.t -> 229 240 (unit, string) result 230 230 - (** [generate_aggregated ~fs ~monorepo ~date ~git_head ~now] generates an aggregated 231 231 - JSON file from all daily JSON files. 241 241 + (** [generate_aggregated ~fs ~monorepo ~date ~git_head ~now] generates an 242 242 + aggregated JSON file from all daily JSON files. 232 243 233 244 This creates a .changes/YYYYMMDD.json file containing all repository entries 234 234 - for the specified date, with change type classification and author aggregation. 245 245 + for the specified date, with change type classification and author 246 246 + aggregation. 235 247 236 248 @param fs Filesystem path 237 249 @param monorepo Path to the monorepo root

+71 -46

lib/changes_aggregated.ml

reviewed

··· 34 34 | New_library -> "new_library" 35 35 | Unknown -> "unknown" 36 36 37 37 - type commit_range = { 38 38 - from_hash : string; 39 39 - to_hash : string; 40 40 - count : int; 41 41 - } 37 37 + type commit_range = { from_hash : string; to_hash : string; count : int } 42 38 43 39 type entry = { 44 40 repository : string; ··· 63 59 (* JSON codecs *) 64 60 65 61 let change_type_jsont = 66 66 - Jsont.enum ~kind:"change_type" [ 67 67 - ("feature", Feature); 68 68 - ("bugfix", Bugfix); 69 69 - ("documentation", Documentation); 70 70 - ("refactor", Refactor); 71 71 - ("new_library", New_library); 72 72 - ("unknown", Unknown); 73 73 - ] 62 62 + Jsont.enum ~kind:"change_type" 63 63 + [ 64 64 + ("feature", Feature); 65 65 + ("bugfix", Bugfix); 66 66 + ("documentation", Documentation); 67 67 + ("refactor", Refactor); 68 68 + ("new_library", New_library); 69 69 + ("unknown", Unknown); 70 70 + ] 74 71 75 72 let commit_range_jsont = 76 73 let make from_hash to_hash count = { from_hash; to_hash; count } in ··· 81 78 |> Jsont.Object.finish 82 79 83 80 let ptime_jsont = 84 84 - let enc t = 85 85 - Ptime.to_rfc3339 t ~tz_offset_s:0 86 86 - in 81 81 + let enc t = Ptime.to_rfc3339 t ~tz_offset_s:0 in 87 82 let dec s = 88 83 match Ptime.of_rfc3339 s with 89 84 | Ok (t, _, _) -> t ··· 92 87 Jsont.map ~dec ~enc Jsont.string 93 88 94 89 let entry_jsont = 95 95 - let make repository hour timestamp summary changes commit_range contributors repo_url change_type = 96 96 - { repository; hour; timestamp; summary; changes; commit_range; contributors; repo_url; change_type } 90 90 + let make repository hour timestamp summary changes commit_range contributors 91 91 + repo_url change_type = 92 92 + { 93 93 + repository; 94 94 + hour; 95 95 + timestamp; 96 96 + summary; 97 97 + changes; 98 98 + commit_range; 99 99 + contributors; 100 100 + repo_url; 101 101 + change_type; 102 102 + } 97 103 in 98 104 (* Default hour and timestamp for backwards compat when reading old files *) 99 105 let default_hour = 0 in 100 106 let default_timestamp = Ptime.epoch in 101 107 Jsont.Object.map ~kind:"aggregated_entry" make 102 108 |> Jsont.Object.mem "repository" Jsont.string ~enc:(fun e -> e.repository) 103 103 - |> Jsont.Object.mem "hour" Jsont.int ~dec_absent:default_hour ~enc:(fun e -> e.hour) 104 104 - |> Jsont.Object.mem "timestamp" ptime_jsont ~dec_absent:default_timestamp ~enc:(fun e -> e.timestamp) 109 109 + |> Jsont.Object.mem "hour" Jsont.int ~dec_absent:default_hour ~enc:(fun e -> 110 110 + e.hour) 111 111 + |> Jsont.Object.mem "timestamp" ptime_jsont ~dec_absent:default_timestamp 112 112 + ~enc:(fun e -> e.timestamp) 105 113 |> Jsont.Object.mem "summary" Jsont.string ~enc:(fun e -> e.summary) 106 106 - |> Jsont.Object.mem "changes" (Jsont.list Jsont.string) ~enc:(fun e -> e.changes) 107 107 - |> Jsont.Object.mem "commit_range" commit_range_jsont ~enc:(fun e -> e.commit_range) 108 108 - |> Jsont.Object.mem "contributors" (Jsont.list Jsont.string) ~dec_absent:[] ~enc:(fun e -> e.contributors) 109 109 - |> Jsont.Object.mem "repo_url" (Jsont.option Jsont.string) ~dec_absent:None ~enc:(fun e -> e.repo_url) 110 110 - |> Jsont.Object.mem "change_type" change_type_jsont ~dec_absent:Unknown ~enc:(fun e -> e.change_type) 114 114 + |> Jsont.Object.mem "changes" (Jsont.list Jsont.string) ~enc:(fun e -> 115 115 + e.changes) 116 116 + |> Jsont.Object.mem "commit_range" commit_range_jsont ~enc:(fun e -> 117 117 + e.commit_range) 118 118 + |> Jsont.Object.mem "contributors" (Jsont.list Jsont.string) ~dec_absent:[] 119 119 + ~enc:(fun e -> e.contributors) 120 120 + |> Jsont.Object.mem "repo_url" (Jsont.option Jsont.string) ~dec_absent:None 121 121 + ~enc:(fun e -> e.repo_url) 122 122 + |> Jsont.Object.mem "change_type" change_type_jsont ~dec_absent:Unknown 123 123 + ~enc:(fun e -> e.change_type) 111 124 |> Jsont.Object.finish 112 125 113 126 let jsont = ··· 118 131 |> Jsont.Object.mem "date" Jsont.string ~enc:(fun t -> t.date) 119 132 |> Jsont.Object.mem "generated_at" ptime_jsont ~enc:(fun t -> t.generated_at) 120 133 |> Jsont.Object.mem "git_head" Jsont.string ~enc:(fun t -> t.git_head) 121 121 - |> Jsont.Object.mem "entries" (Jsont.list entry_jsont) ~enc:(fun t -> t.entries) 122 122 - |> Jsont.Object.mem "authors" (Jsont.list Jsont.string) ~dec_absent:[] ~enc:(fun t -> t.authors) 134 134 + |> Jsont.Object.mem "entries" (Jsont.list entry_jsont) ~enc:(fun t -> 135 135 + t.entries) 136 136 + |> Jsont.Object.mem "authors" (Jsont.list Jsont.string) ~dec_absent:[] 137 137 + ~enc:(fun t -> t.authors) 123 138 |> Jsont.Object.finish 124 139 125 140 (* File I/O *) ··· 137 152 let mm = String.sub yyyymmdd 4 2 in 138 153 let dd = String.sub yyyymmdd 6 2 in 139 154 Some (yyyy ^ "-" ^ mm ^ "-" ^ dd) 140 140 - else 141 141 - None 155 155 + else None 142 156 143 157 let load ~fs ~changes_dir ~date = 144 158 let filename = filename_of_date date in ··· 156 170 (* List all YYYYMMDD.json files and filter by range *) 157 171 let dir_path = Eio.Path.(fs / Fpath.to_string changes_dir) in 158 172 match Eio.Path.kind ~follow:true dir_path with 159 159 - | `Directory -> ( 173 173 + | `Directory -> 160 174 let entries = Eio.Path.read_dir dir_path in 161 161 - let json_files = List.filter (fun f -> 162 162 - String.length f = 13 && String.ends_with ~suffix:".json" f && 163 163 - not (String.contains f '-')) entries 175 175 + let json_files = 176 176 + List.filter 177 177 + (fun f -> 178 178 + String.length f = 13 179 179 + && String.ends_with ~suffix:".json" f 180 180 + && not (String.contains f '-')) 181 181 + entries 164 182 in 165 183 let sorted = List.sort String.compare json_files in 166 184 let from_file = filename_of_date from_date in 167 185 let to_file = filename_of_date to_date in 168 168 - let in_range = List.filter (fun f -> 169 169 - f >= from_file && f <= to_file) sorted 186 186 + let in_range = 187 187 + List.filter (fun f -> f >= from_file && f <= to_file) sorted 170 188 in 171 171 - let results = List.filter_map (fun filename -> 172 172 - match date_of_filename filename with 173 173 - | Some date -> ( 174 174 - match load ~fs ~changes_dir ~date with 175 175 - | Ok t -> Some t 176 176 - | Error _ -> None) 177 177 - | None -> None) in_range 189 189 + let results = 190 190 + List.filter_map 191 191 + (fun filename -> 192 192 + match date_of_filename filename with 193 193 + | Some date -> ( 194 194 + match load ~fs ~changes_dir ~date with 195 195 + | Ok t -> Some t 196 196 + | Error _ -> None) 197 197 + | None -> None) 198 198 + in_range 178 199 in 179 179 - Ok results) 200 200 + Ok results 180 201 | _ -> Error "Changes directory not found" 181 202 | exception Eio.Io _ -> Error "Could not read changes directory" 182 203 ··· 185 206 match Eio.Path.kind ~follow:true dir_path with 186 207 | `Directory -> ( 187 208 let entries = Eio.Path.read_dir dir_path in 188 188 - let json_files = List.filter (fun f -> 189 189 - String.length f = 13 && String.ends_with ~suffix:".json" f && 190 190 - not (String.contains f '-')) entries 209 209 + let json_files = 210 210 + List.filter 211 211 + (fun f -> 212 212 + String.length f = 13 213 213 + && String.ends_with ~suffix:".json" f 214 214 + && not (String.contains f '-')) 215 215 + entries 191 216 in 192 217 match List.sort (fun a b -> String.compare b a) json_files with 193 218 | [] -> Ok None

+30 -29

lib/changes_aggregated.mli

reviewed

··· 14 14 15 15 (** Classification of changes for grouping in broadcasts. *) 16 16 type change_type = 17 17 - | Feature (** New features or capabilities *) 18 18 - | Bugfix (** Bug fixes *) 19 19 - | Documentation (** Documentation updates *) 20 20 - | Refactor (** Code refactoring *) 21 21 - | New_library (** Initial import of a new library *) 22 22 - | Unknown (** Unclassified changes *) 17 17 + | Feature (** New features or capabilities *) 18 18 + | Bugfix (** Bug fixes *) 19 19 + | Documentation (** Documentation updates *) 20 20 + | Refactor (** Code refactoring *) 21 21 + | New_library (** Initial import of a new library *) 22 22 + | Unknown (** Unclassified changes *) 23 23 24 24 val change_type_of_string : string -> change_type 25 25 val string_of_change_type : change_type -> string 26 26 27 27 (** {1 Entry Types} *) 28 28 29 29 - (** Commit range information. *) 30 29 type commit_range = { 31 30 from_hash : string; (** Starting commit hash *) 32 32 - to_hash : string; (** Ending commit hash *) 33 33 - count : int; (** Number of commits in range *) 31 31 + to_hash : string; (** Ending commit hash *) 32 32 + count : int; (** Number of commits in range *) 34 33 } 34 34 + (** Commit range information. *) 35 35 36 36 - (** A single repository's changes for the day. *) 37 36 type entry = { 38 38 - repository : string; (** Repository name *) 39 39 - hour : int; (** Hour of day 0-23 for filtering *) 40 40 - timestamp : Ptime.t; (** RFC3339 timestamp for precise ordering *) 41 41 - summary : string; (** One-line summary of changes *) 42 42 - changes : string list; (** List of change bullet points *) 37 37 + repository : string; (** Repository name *) 38 38 + hour : int; (** Hour of day 0-23 for filtering *) 39 39 + timestamp : Ptime.t; (** RFC3339 timestamp for precise ordering *) 40 40 + summary : string; (** One-line summary of changes *) 41 41 + changes : string list; (** List of change bullet points *) 43 42 commit_range : commit_range; (** Commits included *) 44 44 - contributors : string list; (** Contributors to these changes *) 45 45 - repo_url : string option; (** Optional repository URL *) 46 46 - change_type : change_type; (** Classification of the change *) 43 43 + contributors : string list; (** Contributors to these changes *) 44 44 + repo_url : string option; (** Optional repository URL *) 45 45 + change_type : change_type; (** Classification of the change *) 47 46 } 47 47 + (** A single repository's changes for the day. *) 48 48 49 49 (** {1 Aggregated File Type} *) 50 50 51 51 - (** The complete aggregated daily changes file. *) 52 51 type t = { 53 53 - date : string; (** ISO date YYYY-MM-DD *) 54 54 - generated_at : Ptime.t; (** When this file was generated *) 55 55 - git_head : string; (** Monorepo HEAD at generation time *) 56 56 - entries : entry list; (** All repository entries for this day *) 57 57 - authors : string list; (** All unique authors for this day *) 52 52 + date : string; (** ISO date YYYY-MM-DD *) 53 53 + generated_at : Ptime.t; (** When this file was generated *) 54 54 + git_head : string; (** Monorepo HEAD at generation time *) 55 55 + entries : entry list; (** All repository entries for this day *) 56 56 + authors : string list; (** All unique authors for this day *) 58 57 } 58 58 + (** The complete aggregated daily changes file. *) 59 59 60 60 (** {1 JSON Codecs} *) 61 61 ··· 64 64 65 65 (** {1 File I/O} *) 66 66 67 67 - val load : fs:_ Eio.Path.t -> changes_dir:Fpath.t -> date:string -> (t, string) result 68 68 - (** Load aggregated changes for a specific date. 69 69 - [date] should be in YYYY-MM-DD format. *) 67 67 + val load : 68 68 + fs:_ Eio.Path.t -> changes_dir:Fpath.t -> date:string -> (t, string) result 69 69 + (** Load aggregated changes for a specific date. [date] should be in YYYY-MM-DD 70 70 + format. *) 70 71 71 72 val load_range : 72 73 fs:_ Eio.Path.t -> ··· 74 75 from_date:string -> 75 76 to_date:string -> 76 77 (t list, string) result 77 77 - (** Load all aggregated changes files in date range. 78 78 - Dates should be in YYYY-MM-DD format. *) 78 78 + (** Load all aggregated changes files in date range. Dates should be in 79 79 + YYYY-MM-DD format. *) 79 80 80 81 val latest : fs:_ Eio.Path.t -> changes_dir:Fpath.t -> (t option, string) result 81 82 (** Load the most recent aggregated changes file. *)

+104 -74

lib/changes_daily.ml

reviewed

··· 10 10 [<repo>-<YYYY-MM-DD>.json] and contain timestamped entries for real-time 11 11 tracking. *) 12 12 13 13 - type commit_range = { 14 14 - from_hash : string; 15 15 - to_hash : string; 16 16 - count : int; 17 17 - } 13 13 + type commit_range = { from_hash : string; to_hash : string; count : int } 18 14 19 15 type entry = { 20 16 repository : string; ··· 27 23 repo_url : string option; 28 24 } 29 25 30 30 - type day = { 31 31 - repository : string; 32 32 - date : string; 33 33 - entries : entry list; 34 34 - } 26 26 + type day = { repository : string; date : string; entries : entry list } 35 27 36 36 - module String_map = Map.Make(String) 28 28 + module String_map = Map.Make (String) 37 29 38 30 type t = { 39 31 by_repo : day list String_map.t; ··· 78 70 let default_hour = 0 in 79 71 let default_timestamp = Ptime.epoch in 80 72 Jsont.Object.map ~kind:"daily_entry" make 81 81 - |> Jsont.Object.mem "hour" Jsont.int ~dec_absent:default_hour ~enc:(fun e -> e.hour) 82 82 - |> Jsont.Object.mem "timestamp" ptime_jsont ~dec_absent:default_timestamp ~enc:(fun e -> e.timestamp) 73 73 + |> Jsont.Object.mem "hour" Jsont.int ~dec_absent:default_hour ~enc:(fun e -> 74 74 + e.hour) 75 75 + |> Jsont.Object.mem "timestamp" ptime_jsont ~dec_absent:default_timestamp 76 76 + ~enc:(fun e -> e.timestamp) 83 77 |> Jsont.Object.mem "summary" Jsont.string ~enc:(fun e -> e.summary) 84 84 - |> Jsont.Object.mem "changes" (Jsont.list Jsont.string) ~enc:(fun e -> e.changes) 85 85 - |> Jsont.Object.mem "commit_range" commit_range_jsont ~enc:(fun e -> e.commit_range) 86 86 - |> Jsont.Object.mem "contributors" (Jsont.list Jsont.string) ~dec_absent:[] ~enc:(fun e -> e.contributors) 87 87 - |> Jsont.Object.mem "repo_url" (Jsont.option Jsont.string) ~dec_absent:None ~enc:(fun e -> e.repo_url) 78 78 + |> Jsont.Object.mem "changes" (Jsont.list Jsont.string) ~enc:(fun e -> 79 79 + e.changes) 80 80 + |> Jsont.Object.mem "commit_range" commit_range_jsont ~enc:(fun e -> 81 81 + e.commit_range) 82 82 + |> Jsont.Object.mem "contributors" (Jsont.list Jsont.string) ~dec_absent:[] 83 83 + ~enc:(fun e -> e.contributors) 84 84 + |> Jsont.Object.mem "repo_url" (Jsont.option Jsont.string) ~dec_absent:None 85 85 + ~enc:(fun e -> e.repo_url) 88 86 |> Jsont.Object.finish 89 87 90 90 - type json_file = { 91 91 - json_repository : string; 92 92 - json_entries : file_entry list; 93 93 - } 88 88 + type json_file = { json_repository : string; json_entries : file_entry list } 94 89 95 90 let json_file_jsont = 96 91 let make json_repository json_entries = { json_repository; json_entries } in 97 92 Jsont.Object.map ~kind:"daily_changes_file" make 98 98 - |> Jsont.Object.mem "repository" Jsont.string ~enc:(fun f -> f.json_repository) 99 99 - |> Jsont.Object.mem "entries" (Jsont.list file_entry_jsont) ~enc:(fun f -> f.json_entries) 93 93 + |> Jsont.Object.mem "repository" Jsont.string ~enc:(fun f -> 94 94 + f.json_repository) 95 95 + |> Jsont.Object.mem "entries" (Jsont.list file_entry_jsont) ~enc:(fun f -> 96 96 + f.json_entries) 100 97 |> Jsont.Object.finish 101 98 102 99 (* Parse date from filename: <repo>-<YYYY-MM-DD>.json *) 103 100 let parse_daily_filename filename = 104 101 (* Check for pattern: ends with -YYYY-MM-DD.json *) 105 102 let len = String.length filename in 106 106 - if len < 16 || not (String.ends_with ~suffix:".json" filename) then 107 107 - None 103 103 + if len < 16 || not (String.ends_with ~suffix:".json" filename) then None 108 104 else 109 105 (* Try to extract date: last 15 chars are -YYYY-MM-DD.json *) 110 106 let date_start = len - 15 in 111 107 let potential_date = String.sub filename (date_start + 1) 10 in 112 108 (* Validate date format YYYY-MM-DD *) 113 113 - if String.length potential_date = 10 && 114 114 - potential_date.[4] = '-' && potential_date.[7] = '-' then 109 109 + if 110 110 + String.length potential_date = 10 111 111 + && potential_date.[4] = '-' 112 112 + && potential_date.[7] = '-' 113 113 + then 115 114 let repo = String.sub filename 0 date_start in 116 115 Some (repo, potential_date) 117 117 - else 118 118 - None 116 116 + else None 119 117 120 118 (* Load a single daily file *) 121 119 let load_file ~fs ~changes_dir ~repo ~date : entry list = ··· 126 124 let content = Eio.Path.load file_path in 127 125 match Jsont_bytesrw.decode_string json_file_jsont content with 128 126 | Ok jf -> 129 129 - List.map (fun (fe : file_entry) : entry -> 130 130 - { repository = repo; 131 131 - hour = fe.hour; 132 132 - timestamp = fe.timestamp; 133 133 - summary = fe.summary; 134 134 - changes = fe.changes; 135 135 - commit_range = fe.commit_range; 136 136 - contributors = fe.contributors; 137 137 - repo_url = fe.repo_url; 138 138 - }) jf.json_entries 127 127 + List.map 128 128 + (fun (fe : file_entry) : entry -> 129 129 + { 130 130 + repository = repo; 131 131 + hour = fe.hour; 132 132 + timestamp = fe.timestamp; 133 133 + summary = fe.summary; 134 134 + changes = fe.changes; 135 135 + commit_range = fe.commit_range; 136 136 + contributors = fe.contributors; 137 137 + repo_url = fe.repo_url; 138 138 + }) 139 139 + jf.json_entries 139 140 | Error _ -> []) 140 141 | _ -> [] 141 142 | exception Eio.Io _ -> [] 142 143 143 143 - let empty = { 144 144 - by_repo = String_map.empty; 145 145 - by_date = String_map.empty; 146 146 - all_entries = []; 147 147 - } 144 144 + let empty = 145 145 + { by_repo = String_map.empty; by_date = String_map.empty; all_entries = [] } 148 146 149 147 let list_repos ~fs ~changes_dir = 150 148 let dir_path = Eio.Path.(fs / Fpath.to_string changes_dir) in ··· 168 166 match parse_daily_filename filename with 169 167 | Some (r, date) when r = repo -> Some date 170 168 | _ -> None) 171 171 - |> List.sort (fun a b -> String.compare b a) (* descending *) 169 169 + |> List.sort (fun a b -> String.compare b a) 170 170 + (* descending *) 172 171 | _ -> [] 173 172 | exception Eio.Io _ -> [] 174 173 ··· 187 186 let parsed_files = List.filter_map parse_daily_filename files in 188 187 189 188 (* Load all files and build days *) 190 190 - let days : day list = List.filter_map (fun (repo, date) -> 191 191 - let loaded_entries : entry list = load_file ~fs ~changes_dir ~repo ~date in 192 192 - if loaded_entries = [] then None 193 193 - else 194 194 - let sorted_entries : entry list = List.sort (fun (e1 : entry) (e2 : entry) -> 195 195 - Ptime.compare e1.timestamp e2.timestamp) loaded_entries 196 196 - in 197 197 - Some ({ repository = repo; date; entries = sorted_entries } : day) 198 198 - ) parsed_files in 189 189 + let days : day list = 190 190 + List.filter_map 191 191 + (fun (repo, date) -> 192 192 + let loaded_entries : entry list = 193 193 + load_file ~fs ~changes_dir ~repo ~date 194 194 + in 195 195 + if loaded_entries = [] then None 196 196 + else 197 197 + let sorted_entries : entry list = 198 198 + List.sort 199 199 + (fun (e1 : entry) (e2 : entry) -> 200 200 + Ptime.compare e1.timestamp e2.timestamp) 201 201 + loaded_entries 202 202 + in 203 203 + Some ({ repository = repo; date; entries = sorted_entries } : day)) 204 204 + parsed_files 205 205 + in 199 206 200 207 (* Build by_repo map *) 201 201 - let by_repo : day list String_map.t = List.fold_left (fun acc (d : day) -> 202 202 - let existing = String_map.find_opt d.repository acc |> Option.value ~default:[] in 203 203 - String_map.add d.repository (d :: existing) acc 204 204 - ) String_map.empty days in 208 208 + let by_repo : day list String_map.t = 209 209 + List.fold_left 210 210 + (fun acc (d : day) -> 211 211 + let existing = 212 212 + String_map.find_opt d.repository acc |> Option.value ~default:[] 213 213 + in 214 214 + String_map.add d.repository (d :: existing) acc) 215 215 + String_map.empty days 216 216 + in 205 217 206 218 (* Sort each repo's days by date descending *) 207 207 - let by_repo : day list String_map.t = String_map.map (fun (ds : day list) -> 208 208 - List.sort (fun (d1 : day) (d2 : day) -> String.compare d2.date d1.date) ds 209 209 - ) by_repo in 219 219 + let by_repo : day list String_map.t = 220 220 + String_map.map 221 221 + (fun (ds : day list) -> 222 222 + List.sort 223 223 + (fun (d1 : day) (d2 : day) -> String.compare d2.date d1.date) 224 224 + ds) 225 225 + by_repo 226 226 + in 210 227 211 228 (* Build by_date map *) 212 212 - let by_date : day list String_map.t = List.fold_left (fun acc (d : day) -> 213 213 - let existing = String_map.find_opt d.date acc |> Option.value ~default:[] in 214 214 - String_map.add d.date (d :: existing) acc 215 215 - ) String_map.empty days in 229 229 + let by_date : day list String_map.t = 230 230 + List.fold_left 231 231 + (fun acc (d : day) -> 232 232 + let existing = 233 233 + String_map.find_opt d.date acc |> Option.value ~default:[] 234 234 + in 235 235 + String_map.add d.date (d :: existing) acc) 236 236 + String_map.empty days 237 237 + in 216 238 217 239 (* Sort each date's days by repo name *) 218 218 - let by_date : day list String_map.t = String_map.map (fun (ds : day list) -> 219 219 - List.sort (fun (d1 : day) (d2 : day) -> String.compare d1.repository d2.repository) ds 220 220 - ) by_date in 240 240 + let by_date : day list String_map.t = 241 241 + String_map.map 242 242 + (fun (ds : day list) -> 243 243 + List.sort 244 244 + (fun (d1 : day) (d2 : day) -> 245 245 + String.compare d1.repository d2.repository) 246 246 + ds) 247 247 + by_date 248 248 + in 221 249 222 250 (* Collect all entries sorted by timestamp *) 223 251 let all_entries : entry list = 224 252 days 225 253 |> List.concat_map (fun (d : day) -> d.entries) 226 226 - |> List.sort (fun (e1 : entry) (e2 : entry) -> Ptime.compare e1.timestamp e2.timestamp) 254 254 + |> List.sort (fun (e1 : entry) (e2 : entry) -> 255 255 + Ptime.compare e1.timestamp e2.timestamp) 227 256 in 228 257 229 258 { by_repo; by_date; all_entries } 230 230 - 231 259 | _ -> empty 232 260 | exception Eio.Io _ -> empty 233 261 234 262 let since (t : t) (timestamp : Ptime.t) : entry list = 235 235 - List.filter (fun (e : entry) -> Ptime.compare e.timestamp timestamp > 0) t.all_entries 263 263 + List.filter 264 264 + (fun (e : entry) -> Ptime.compare e.timestamp timestamp > 0) 265 265 + t.all_entries 236 266 237 267 let for_repo t repo = 238 268 String_map.find_opt repo t.by_repo |> Option.value ~default:[] ··· 240 270 let for_date t date = 241 271 String_map.find_opt date t.by_date |> Option.value ~default:[] 242 272 243 243 - let repos t = 244 244 - String_map.bindings t.by_repo |> List.map fst 273 273 + let repos t = String_map.bindings t.by_repo |> List.map fst 245 274 246 275 let dates t = 247 276 String_map.bindings t.by_date 248 277 |> List.map fst 249 249 - |> List.sort (fun a b -> String.compare b a) (* descending *) 278 278 + |> List.sort (fun a b -> String.compare b a) 279 279 + (* descending *) 250 280 251 281 let entries_since ~fs ~changes_dir ~since:timestamp = 252 282 let t = load_all ~fs ~changes_dir in

+14 -24

lib/changes_daily.mli

reviewed

··· 12 12 13 13 (** {1 Types} *) 14 14 15 15 - type commit_range = { 16 16 - from_hash : string; 17 17 - to_hash : string; 18 18 - count : int; 19 19 - } 15 15 + type commit_range = { from_hash : string; to_hash : string; count : int } 20 16 (** Commit range information. *) 21 17 22 18 type entry = { ··· 43 39 44 40 type t = { 45 41 by_repo : day list String_map.t; 46 46 - (** Map from repository name to list of days. *) 42 42 + (** Map from repository name to list of days. *) 47 43 by_date : day list String_map.t; 48 48 - (** Map from date (YYYY-MM-DD) to list of days across repos. *) 49 49 - all_entries : entry list; 50 50 - (** All entries sorted by timestamp ascending. *) 44 44 + (** Map from date (YYYY-MM-DD) to list of days across repos. *) 45 45 + all_entries : entry list; (** All entries sorted by timestamp ascending. *) 51 46 } 52 47 (** Immutable collection of all loaded daily changes. *) 53 48 ··· 57 52 (** Empty daily changes structure. *) 58 53 59 54 val load_all : fs:_ Eio.Path.t -> changes_dir:Fpath.t -> t 60 60 - (** [load_all ~fs ~changes_dir] loads all [<repo>-<YYYY-MM-DD>.json] files 61 61 - from the changes directory and returns an immutable structure for querying. *) 55 55 + (** [load_all ~fs ~changes_dir] loads all [<repo>-<YYYY-MM-DD>.json] files from 56 56 + the changes directory and returns an immutable structure for querying. *) 62 57 63 58 (** {1 Querying} *) 64 59 ··· 67 62 sorted by timestamp ascending. *) 68 63 69 64 val for_repo : t -> string -> day list 70 70 - (** [for_repo t repo] returns all days for the given repository, 71 71 - sorted by date descending. *) 65 65 + (** [for_repo t repo] returns all days for the given repository, sorted by date 66 66 + descending. *) 72 67 73 68 val for_date : t -> string -> day list 74 69 (** [for_date t date] returns all days (across repos) for the given date. *) ··· 82 77 (** {1 File Discovery} *) 83 78 84 79 val list_repos : fs:_ Eio.Path.t -> changes_dir:Fpath.t -> string list 85 85 - (** [list_repos ~fs ~changes_dir] returns all repository names that have 86 86 - daily change files. *) 80 80 + (** [list_repos ~fs ~changes_dir] returns all repository names that have daily 81 81 + change files. *) 87 82 88 88 - val list_dates : fs:_ Eio.Path.t -> changes_dir:Fpath.t -> repo:string -> string list 83 83 + val list_dates : 84 84 + fs:_ Eio.Path.t -> changes_dir:Fpath.t -> repo:string -> string list 89 85 (** [list_dates ~fs ~changes_dir ~repo] returns all dates for which the given 90 86 repository has change files. *) 91 87 ··· 101 97 repo and date. Returns empty list if file doesn't exist. *) 102 98 103 99 val load_repo_all : 104 104 - fs:_ Eio.Path.t -> 105 105 - changes_dir:Fpath.t -> 106 106 - repo:string -> 107 107 - entry list 100 100 + fs:_ Eio.Path.t -> changes_dir:Fpath.t -> repo:string -> entry list 108 101 (** [load_repo_all ~fs ~changes_dir ~repo] loads all entries for a repository 109 102 across all dates. *) 110 103 111 104 val entries_since : 112 112 - fs:_ Eio.Path.t -> 113 113 - changes_dir:Fpath.t -> 114 114 - since:Ptime.t -> 115 115 - entry list 105 105 + fs:_ Eio.Path.t -> changes_dir:Fpath.t -> since:Ptime.t -> entry list 116 106 (** [entries_since ~fs ~changes_dir ~since] returns all entries created after 117 107 the given timestamp, useful for real-time updates. *)

+105 -67

lib/changes_query.ml

reviewed

··· 19 19 let (y, m, d), _ = Ptime.to_date_time now in 20 20 Printf.sprintf "%04d-%02d-%02d" y m d 21 21 in 22 22 - match Changes_aggregated.load_range ~fs ~changes_dir ~from_date:since_date ~to_date:now_date with 22 22 + match 23 23 + Changes_aggregated.load_range ~fs ~changes_dir ~from_date:since_date 24 24 + ~to_date:now_date 25 25 + with 23 26 | Error e -> Error e 24 27 | Ok aggregated_files -> 25 28 (* Filter to files generated after 'since' and collect entries *) 26 26 - let entries = List.concat_map (fun (agg : Changes_aggregated.t) -> 27 27 - if Ptime.compare agg.generated_at since > 0 then 28 28 - agg.entries 29 29 - else 30 30 - []) aggregated_files 29 29 + let entries = 30 30 + List.concat_map 31 31 + (fun (agg : Changes_aggregated.t) -> 32 32 + if Ptime.compare agg.generated_at since > 0 then agg.entries else []) 33 33 + aggregated_files 31 34 in 32 35 Ok entries 33 36 ··· 39 42 let format_repo_link repo url_opt = 40 43 match url_opt with 41 44 | Some url -> Printf.sprintf "[%s](%s)" repo url 42 42 - | None -> Printf.sprintf "[%s](https://tangled.org/@anil.recoil.org/%s.git)" repo repo 45 45 + | None -> repo (* No URL available, just use repo name *) 43 46 44 47 let format_for_zulip ~entries ~include_date ~date = 45 45 - if entries = [] then 46 46 - "No changes to report." 48 48 + if entries = [] then "No changes to report." 47 49 else begin 48 50 let buf = Buffer.create 1024 in 49 51 if include_date then begin ··· 52 54 | None -> Buffer.add_string buf "Recent updates:\n\n" 53 55 end; 54 56 (* Group by change type *) 55 55 - let by_type = [ 56 56 - (Changes_aggregated.New_library, "New Libraries", []); 57 57 - (Changes_aggregated.Feature, "Features", []); 58 58 - (Changes_aggregated.Bugfix, "Bug Fixes", []); 59 59 - (Changes_aggregated.Documentation, "Documentation", []); 60 60 - (Changes_aggregated.Refactor, "Improvements", []); 61 61 - (Changes_aggregated.Unknown, "Other Changes", []); 62 62 - ] in 63 63 - let grouped = List.map (fun (ct, title, _) -> 64 64 - let matching = List.filter (fun (e : Changes_aggregated.entry) -> e.change_type = ct) entries in 65 65 - (ct, title, matching)) by_type 57 57 + let by_type = 58 58 + [ 59 59 + (Changes_aggregated.New_library, "New Libraries", []); 60 60 + (Changes_aggregated.Feature, "Features", []); 61 61 + (Changes_aggregated.Bugfix, "Bug Fixes", []); 62 62 + (Changes_aggregated.Documentation, "Documentation", []); 63 63 + (Changes_aggregated.Refactor, "Improvements", []); 64 64 + (Changes_aggregated.Unknown, "Other Changes", []); 65 65 + ] 66 66 in 67 67 - List.iter (fun (_ct, title, entries) -> 68 68 - if entries <> [] then begin 69 69 - Buffer.add_string buf (Printf.sprintf "### %s\n\n" title); 70 70 - List.iter (fun (entry : Changes_aggregated.entry) -> 71 71 - let repo_link = format_repo_link entry.repository entry.repo_url in 72 72 - Buffer.add_string buf (Printf.sprintf "**%s**: %s\n" repo_link entry.summary); 73 73 - List.iter (fun change -> 74 74 - Buffer.add_string buf (Printf.sprintf "- %s\n" change)) entry.changes; 75 75 - if entry.contributors <> [] then 76 76 - Buffer.add_string buf (Printf.sprintf "*Contributors: %s*\n" 77 77 - (String.concat ", " entry.contributors)); 78 78 - Buffer.add_string buf "\n") entries 79 79 - end) grouped; 67 67 + let grouped = 68 68 + List.map 69 69 + (fun (ct, title, _) -> 70 70 + let matching = 71 71 + List.filter 72 72 + (fun (e : Changes_aggregated.entry) -> e.change_type = ct) 73 73 + entries 74 74 + in 75 75 + (ct, title, matching)) 76 76 + by_type 77 77 + in 78 78 + List.iter 79 79 + (fun (_ct, title, entries) -> 80 80 + if entries <> [] then begin 81 81 + Buffer.add_string buf (Printf.sprintf "### %s\n\n" title); 82 82 + List.iter 83 83 + (fun (entry : Changes_aggregated.entry) -> 84 84 + let repo_link = 85 85 + format_repo_link entry.repository entry.repo_url 86 86 + in 87 87 + Buffer.add_string buf 88 88 + (Printf.sprintf "**%s**: %s\n" repo_link entry.summary); 89 89 + List.iter 90 90 + (fun change -> 91 91 + Buffer.add_string buf (Printf.sprintf "- %s\n" change)) 92 92 + entry.changes; 93 93 + if entry.contributors <> [] then 94 94 + Buffer.add_string buf 95 95 + (Printf.sprintf "*Contributors: %s*\n" 96 96 + (String.concat ", " entry.contributors)); 97 97 + Buffer.add_string buf "\n") 98 98 + entries 99 99 + end) 100 100 + grouped; 80 101 Buffer.contents buf 81 102 end 82 103 83 104 let format_summary ~entries = 84 84 - if entries = [] then 85 85 - "No new changes." 105 105 + if entries = [] then "No new changes." 86 106 else 87 107 let count = List.length entries in 88 88 - let repos = List.sort_uniq String.compare 89 89 - (List.map (fun (e : Changes_aggregated.entry) -> e.repository) entries) in 90 90 - Printf.sprintf "%d change%s across %d repositor%s: %s" 91 91 - count (if count = 1 then "" else "s") 92 92 - (List.length repos) (if List.length repos = 1 then "y" else "ies") 108 108 + let repos = 109 109 + List.sort_uniq String.compare 110 110 + (List.map (fun (e : Changes_aggregated.entry) -> e.repository) entries) 111 111 + in 112 112 + Printf.sprintf "%d change%s across %d repositor%s: %s" count 113 113 + (if count = 1 then "" else "s") 114 114 + (List.length repos) 115 115 + (if List.length repos = 1 then "y" else "ies") 93 116 (String.concat ", " repos) 94 117 95 118 (** {1 Daily Changes (Real-time)} *) ··· 101 124 daily_changes_since ~fs ~changes_dir ~since <> [] 102 125 103 126 let format_daily_for_zulip ~entries ~include_date ~date = 104 104 - if entries = [] then 105 105 - "No changes to report." 127 127 + if entries = [] then "No changes to report." 106 128 else begin 107 129 let buf = Buffer.create 1024 in 108 130 if include_date then begin 109 131 match date with 110 110 - | Some d -> Buffer.add_string buf (Printf.sprintf "## Changes for %s\n\n" d) 132 132 + | Some d -> 133 133 + Buffer.add_string buf (Printf.sprintf "## Changes for %s\n\n" d) 111 134 | None -> Buffer.add_string buf "## Recent Changes\n\n" 112 135 end; 113 136 (* Group by repository *) 114 114 - let repos = List.sort_uniq String.compare 115 115 - (List.map (fun (e : Changes_daily.entry) -> e.repository) entries) in 116 116 - List.iter (fun repo -> 117 117 - let repo_entries = List.filter (fun (e : Changes_daily.entry) -> e.repository = repo) entries in 118 118 - if repo_entries <> [] then begin 119 119 - let first_entry = List.hd repo_entries in 120 120 - let repo_link = format_repo_link repo first_entry.repo_url in 121 121 - Buffer.add_string buf (Printf.sprintf "### %s\n\n" repo_link); 122 122 - List.iter (fun (entry : Changes_daily.entry) -> 123 123 - Buffer.add_string buf (Printf.sprintf "**%s**\n" entry.summary); 124 124 - List.iter (fun change -> 125 125 - Buffer.add_string buf (Printf.sprintf "- %s\n" change)) entry.changes; 126 126 - if entry.contributors <> [] then 127 127 - Buffer.add_string buf (Printf.sprintf "*Contributors: %s*\n" 128 128 - (String.concat ", " entry.contributors)); 129 129 - Buffer.add_string buf "\n") repo_entries 130 130 - end) repos; 137 137 + let repos = 138 138 + List.sort_uniq String.compare 139 139 + (List.map (fun (e : Changes_daily.entry) -> e.repository) entries) 140 140 + in 141 141 + List.iter 142 142 + (fun repo -> 143 143 + let repo_entries = 144 144 + List.filter 145 145 + (fun (e : Changes_daily.entry) -> e.repository = repo) 146 146 + entries 147 147 + in 148 148 + if repo_entries <> [] then begin 149 149 + let first_entry = List.hd repo_entries in 150 150 + let repo_link = format_repo_link repo first_entry.repo_url in 151 151 + Buffer.add_string buf (Printf.sprintf "### %s\n\n" repo_link); 152 152 + List.iter 153 153 + (fun (entry : Changes_daily.entry) -> 154 154 + Buffer.add_string buf (Printf.sprintf "**%s**\n" entry.summary); 155 155 + List.iter 156 156 + (fun change -> 157 157 + Buffer.add_string buf (Printf.sprintf "- %s\n" change)) 158 158 + entry.changes; 159 159 + if entry.contributors <> [] then 160 160 + Buffer.add_string buf 161 161 + (Printf.sprintf "*Contributors: %s*\n" 162 162 + (String.concat ", " entry.contributors)); 163 163 + Buffer.add_string buf "\n") 164 164 + repo_entries 165 165 + end) 166 166 + repos; 131 167 Buffer.contents buf 132 168 end 133 169 134 170 let format_daily_summary ~entries = 135 135 - if entries = [] then 136 136 - "No new changes." 171 171 + if entries = [] then "No new changes." 137 172 else 138 173 let count = List.length entries in 139 139 - let repos = List.sort_uniq String.compare 140 140 - (List.map (fun (e : Changes_daily.entry) -> e.repository) entries) in 141 141 - Printf.sprintf "%d change%s across %d repositor%s: %s" 142 142 - count (if count = 1 then "" else "s") 143 143 - (List.length repos) (if List.length repos = 1 then "y" else "ies") 174 174 + let repos = 175 175 + List.sort_uniq String.compare 176 176 + (List.map (fun (e : Changes_daily.entry) -> e.repository) entries) 177 177 + in 178 178 + Printf.sprintf "%d change%s across %d repositor%s: %s" count 179 179 + (if count = 1 then "" else "s") 180 180 + (List.length repos) 181 181 + (if List.length repos = 1 then "y" else "ies") 144 182 (String.concat ", " repos)

+12 -24

lib/changes_query.mli

reviewed

··· 16 16 since:Ptime.t -> 17 17 now:Ptime.t -> 18 18 (Changes_aggregated.entry list, string) result 19 19 - (** Get all change entries from aggregated files created after [since]. 20 20 - Returns entries from all days after the timestamp. 19 19 + (** Get all change entries from aggregated files created after [since]. Returns 20 20 + entries from all days after the timestamp. 21 21 @param now Current time for determining the date range end. *) 22 22 23 23 val has_new_changes : 24 24 - fs:_ Eio.Path.t -> 25 25 - changes_dir:Fpath.t -> 26 26 - since:Ptime.t -> 27 27 - now:Ptime.t -> 28 28 - bool 24 24 + fs:_ Eio.Path.t -> changes_dir:Fpath.t -> since:Ptime.t -> now:Ptime.t -> bool 29 25 (** Check if there are any new changes since the given timestamp. 30 26 @param now Current time for determining the date range end. *) 31 27 ··· 36 32 include_date:bool -> 37 33 date:string option -> 38 34 string 39 39 - (** Format entries as markdown suitable for Zulip. 40 40 - If [include_date] is true, includes a date header. 41 41 - [date] is used for the header if provided. *) 35 35 + (** Format entries as markdown suitable for Zulip. If [include_date] is true, 36 36 + includes a date header. [date] is used for the header if provided. *) 42 37 43 43 - val format_summary : 44 44 - entries:Changes_aggregated.entry list -> 45 45 - string 38 38 + val format_summary : entries:Changes_aggregated.entry list -> string 46 39 (** Format a brief summary of the changes. *) 47 40 48 41 (** {1 Daily Changes (Real-time)} *) ··· 52 45 changes_dir:Fpath.t -> 53 46 since:Ptime.t -> 54 47 Changes_daily.entry list 55 55 - (** Get all daily change entries created after [since] timestamp. 56 56 - Uses the per-day-per-repo files for real-time access. *) 48 48 + (** Get all daily change entries created after [since] timestamp. Uses the 49 49 + per-day-per-repo files for real-time access. *) 57 50 58 51 val has_new_daily_changes : 59 59 - fs:_ Eio.Path.t -> 60 60 - changes_dir:Fpath.t -> 61 61 - since:Ptime.t -> 62 62 - bool 52 52 + fs:_ Eio.Path.t -> changes_dir:Fpath.t -> since:Ptime.t -> bool 63 53 (** Check if there are any new daily changes since the given timestamp. *) 64 54 65 55 val format_daily_for_zulip : ··· 67 57 include_date:bool -> 68 58 date:string option -> 69 59 string 70 70 - (** Format daily entries as markdown suitable for Zulip. 71 71 - Groups entries by repository. *) 60 60 + (** Format daily entries as markdown suitable for Zulip. Groups entries by 61 61 + repository. *) 72 62 73 73 - val format_daily_summary : 74 74 - entries:Changes_daily.entry list -> 75 75 - string 63 63 + val format_daily_summary : entries:Changes_daily.entry list -> string 76 64 (** Format a brief summary of daily changes. *)

+197 -93

lib/config.ml

reviewed

··· 1 1 + (** Unified configuration for monopam. 2 2 + 3 3 + Configuration is stored in TOML format at ~/.config/monopam/opamverse.toml *) 4 4 + 5 5 + let app_name = "monopam" 6 6 + 7 7 + (** {1 Package Overrides} *) 8 8 + 1 9 module Package_config = struct 2 10 type t = { branch : string option } 3 11 ··· 11 19 |> finish)) 12 20 end 13 21 22 22 + (** {1 Paths Configuration} *) 23 23 + 24 24 + type paths = { 25 25 + mono : string; (** Monorepo directory (default: "mono") *) 26 26 + src : string; (** Source checkouts directory (default: "src") *) 27 27 + verse : string; (** Verse directory (default: "verse") *) 28 28 + } 29 29 + 30 30 + let default_paths = { mono = "mono"; src = "src"; verse = "verse" } 31 31 + 32 32 + (** {1 Main Configuration Type} *) 33 33 + 14 34 type t = { 15 15 - opam_repo : Fpath.t; 16 16 - checkouts : Fpath.t; 17 17 - monorepo : Fpath.t; 18 18 - default_branch : string; 35 35 + (* Workspace structure *) 36 36 + root : Fpath.t; 37 37 + paths : paths; 38 38 + (* Identity *) 39 39 + handle : string; 40 40 + knot : string; (** Git push server hostname (e.g., "git.recoil.org") *) 41 41 + (* Package overrides *) 19 42 packages : (string * Package_config.t) list; 20 43 } 21 44 45 45 + (** {1 Accessors} *) 46 46 + 47 47 + let root t = t.root 48 48 + let handle t = t.handle 49 49 + let knot t = t.knot 50 50 + let paths t = t.paths 51 51 + let packages t = t.packages 52 52 + let package_config t name = List.assoc_opt name t.packages 53 53 + 54 54 + (* Derived paths *) 55 55 + let default_branch = "main" 56 56 + let mono_path t = Fpath.(t.root / t.paths.mono) 57 57 + let src_path t = Fpath.(t.root / t.paths.src) 58 58 + let opam_repo_path t = Fpath.(t.root / "opam-repo") 59 59 + let verse_path t = Fpath.(t.root / t.paths.verse) 60 60 + 61 61 + (* Aliases for backwards compatibility with old Config.Paths module *) 22 62 module Paths = struct 23 23 - let opam_repo t = t.opam_repo 24 24 - let checkouts t = t.checkouts 25 25 - let monorepo t = t.monorepo 63 63 + let opam_repo = opam_repo_path 64 64 + let checkouts = src_path 65 65 + let monorepo = mono_path 26 66 end 27 67 28 28 - let default_branch t = t.default_branch 29 29 - let package_config t name = List.assoc_opt name t.packages 68 68 + (** {1 XDG Paths} *) 69 69 + 70 70 + let xdg_config_home () = 71 71 + match Sys.getenv_opt "XDG_CONFIG_HOME" with 72 72 + | Some dir when dir <> "" -> Fpath.v dir 73 73 + | _ -> ( 74 74 + match Sys.getenv_opt "HOME" with 75 75 + | Some home -> Fpath.(v home / ".config") 76 76 + | None -> Fpath.v "/tmp") 77 77 + 78 78 + let xdg_data_home () = 79 79 + match Sys.getenv_opt "XDG_DATA_HOME" with 80 80 + | Some dir when dir <> "" -> Fpath.v dir 81 81 + | _ -> ( 82 82 + match Sys.getenv_opt "HOME" with 83 83 + | Some home -> Fpath.(v home / ".local" / "share") 84 84 + | None -> Fpath.v "/tmp") 85 85 + 86 86 + let xdg_cache_home () = 87 87 + match Sys.getenv_opt "XDG_CACHE_HOME" with 88 88 + | Some dir when dir <> "" -> Fpath.v dir 89 89 + | _ -> 90 90 + match Sys.getenv_opt "HOME" with 91 91 + | Some home -> Fpath.(v home / ".cache") 92 92 + | None -> Fpath.v "/tmp" 30 93 31 31 - let create ~opam_repo ~checkouts ~monorepo ?(default_branch = "main") () = 32 32 - { opam_repo; checkouts; monorepo; default_branch; packages = [] } 94 94 + let config_dir () = Fpath.(xdg_config_home () / app_name) 95 95 + let data_dir () = Fpath.(xdg_data_home () / app_name) 96 96 + let cache_dir () = Fpath.(xdg_cache_home () / app_name) 97 97 + let config_file () = Fpath.(config_dir () / "opamverse.toml") 98 98 + let registry_path () = Fpath.(data_dir () / "opamverse-registry") 33 99 34 34 - let with_package_override t ~name ~branch:b = 35 35 - let pkg_config = Package_config.{ branch = Some b } in 100 100 + (** {1 Construction} *) 101 101 + 102 102 + (** Derive knot (git push server) from handle. 103 103 + E.g., "anil.recoil.org" -> "git.recoil.org" *) 104 104 + let default_knot_from_handle handle = 105 105 + match String.index_opt handle '.' with 106 106 + | None -> "git." ^ handle (* fallback *) 107 107 + | Some i -> 108 108 + let domain = String.sub handle (i + 1) (String.length handle - i - 1) in 109 109 + "git." ^ domain 110 110 + 111 111 + let create ~root ~handle ?knot ?(packages = []) ?(paths = default_paths) () = 112 112 + let knot = match knot with Some k -> k | None -> default_knot_from_handle handle in 113 113 + { root; handle; knot; packages; paths } 114 114 + 115 115 + let with_package_override t ~name ?branch:branch_opt () = 116 116 + let existing = List.assoc_opt name t.packages in 117 117 + let existing_branch = Option.bind existing Package_config.branch in 118 118 + let new_branch = 119 119 + match branch_opt with Some _ -> branch_opt | None -> existing_branch 120 120 + in 121 121 + let pkg_config = Package_config.{ branch = new_branch } in 36 122 let packages = (name, pkg_config) :: List.remove_assoc name t.packages in 37 123 { t with packages } 124 124 + 125 125 + (** {1 TOML Codecs} *) 38 126 39 127 let expand_tilde s = 40 128 if String.length s > 0 && s.[0] = '~' then ··· 53 141 match Fpath.of_string s with Ok p -> p | Error (`Msg m) -> failwith m) 54 142 ~enc:Fpath.to_string Tomlt.string 55 143 56 56 - let codec : t Tomlt.t = 144 144 + let paths_codec : paths Tomlt.t = 57 145 Tomlt.( 58 146 Table.( 59 59 - obj (fun opam_repo checkouts monorepo default_branch packages -> 60 60 - { 61 61 - opam_repo; 62 62 - checkouts; 63 63 - monorepo; 64 64 - default_branch = Option.value ~default:"main" default_branch; 65 65 - packages; 66 66 - }) 67 67 - |> mem "opam_repo" fpath_codec ~enc:(fun c -> c.opam_repo) 68 68 - |> mem "checkouts" fpath_codec ~enc:(fun c -> c.checkouts) 69 69 - |> mem "monorepo" fpath_codec ~enc:(fun c -> c.monorepo) 70 70 - |> opt_mem "default_branch" string ~enc:(fun c -> 71 71 - if c.default_branch = "main" then None else Some c.default_branch) 72 72 - |> keep_unknown 73 73 - ~enc:(fun c -> c.packages) 147 147 + obj (fun mono src verse -> 148 148 + { mono = Option.value ~default:default_paths.mono mono; 149 149 + src = Option.value ~default:default_paths.src src; 150 150 + verse = Option.value ~default:default_paths.verse verse }) 151 151 + |> opt_mem "mono" string ~enc:(fun p -> Some p.mono) 152 152 + |> opt_mem "src" string ~enc:(fun p -> Some p.src) 153 153 + |> opt_mem "verse" string ~enc:(fun p -> Some p.verse) 154 154 + |> finish)) 155 155 + 156 156 + (* TOML structure: 157 157 + [workspace] 158 158 + root = "~/tangled" 159 159 + 160 160 + [identity] 161 161 + handle = "anil.recoil.org" 162 162 + knot = "git.recoil.org" 163 163 + 164 164 + [paths] 165 165 + mono = "mono" 166 166 + src = "src" 167 167 + 168 168 + [packages.braid] 169 169 + branch = "backport-fix" 170 170 + *) 171 171 + 172 172 + type workspace_section = { w_root : Fpath.t } 173 173 + type identity_section = { i_handle : string; i_knot : string option } 174 174 + 175 175 + let default_knot = "git.recoil.org" 176 176 + 177 177 + let workspace_codec : workspace_section Tomlt.t = 178 178 + Tomlt.( 179 179 + Table.( 180 180 + obj (fun w_root -> { w_root }) 181 181 + |> mem "root" fpath_codec ~enc:(fun w -> w.w_root) 182 182 + |> finish)) 183 183 + 184 184 + let identity_codec : identity_section Tomlt.t = 185 185 + Tomlt.( 186 186 + Table.( 187 187 + obj (fun i_handle i_knot -> { i_handle; i_knot }) 188 188 + |> mem "handle" string ~enc:(fun i -> i.i_handle) 189 189 + |> opt_mem "knot" string ~enc:(fun i -> i.i_knot) 190 190 + |> finish)) 191 191 + 192 192 + (* Codec for the [packages] table which contains subtree->override mappings *) 193 193 + let packages_table_codec : (string * Package_config.t) list Tomlt.t = 194 194 + Tomlt.( 195 195 + Table.( 196 196 + obj (fun pkgs -> pkgs) 197 197 + |> keep_unknown ~enc:(fun pkgs -> pkgs) 74 198 (Mems.assoc Package_config.codec) 75 199 |> finish)) 76 200 201 201 + let codec : t Tomlt.t = 202 202 + Tomlt.( 203 203 + Table.( 204 204 + obj (fun workspace identity packages paths -> 205 205 + let packages = Option.value ~default:[] packages in 206 206 + let paths = Option.value ~default:default_paths paths in 207 207 + let knot = Option.value ~default:default_knot identity.i_knot in 208 208 + { root = workspace.w_root; handle = identity.i_handle; knot; packages; paths }) 209 209 + |> mem "workspace" workspace_codec ~enc:(fun t -> { w_root = t.root }) 210 210 + |> mem "identity" identity_codec ~enc:(fun t -> { i_handle = t.handle; i_knot = Some t.knot }) 211 211 + |> opt_mem "packages" packages_table_codec 212 212 + ~enc:(fun t -> if t.packages = [] then None else Some t.packages) 213 213 + |> opt_mem "paths" paths_codec 214 214 + ~enc:(fun t -> if t.paths = default_paths then None else Some t.paths) 215 215 + |> finish)) 216 216 + 217 217 + (** {1 Validation} *) 218 218 + 77 219 type validation_error = 78 220 | Path_not_found of string * Fpath.t 79 221 | Not_a_directory of string * Fpath.t ··· 98 240 Hint: Use an absolute path starting with / or ~/" 99 241 field Fpath.pp path 100 242 101 101 - let validate ~fs t = 102 102 - (* Get the root filesystem for checking absolute paths *) 103 103 - let root_fs = 104 104 - let dir, _ = (fs : _ Eio.Path.t) in 105 105 - (dir, "") 106 106 - in 107 107 - let check_absolute field path = 108 108 - if Fpath.is_abs path then Ok () else Error (Relative_path (field, path)) 109 109 - in 110 110 - let check_dir field path = 111 111 - let eio_path = Eio.Path.(root_fs / Fpath.to_string path) in 112 112 - match Eio.Path.kind ~follow:true eio_path with 113 113 - | `Directory -> Ok () 114 114 - | `Regular_file | `Symbolic_link | `Block_device | `Character_special 115 115 - | `Fifo | `Socket | `Unknown | `Not_found -> 116 116 - Error (Not_a_directory (field, path)) 117 117 - | exception Eio.Io (Eio.Fs.E (Not_found _), _) -> 118 118 - Error (Path_not_found (field, path)) 119 119 - | exception _ -> Error (Path_not_found (field, path)) 120 120 - in 121 121 - let check_opam_repo path = 122 122 - let packages_dir = Fpath.(path / "packages") in 123 123 - let eio_path = Eio.Path.(root_fs / Fpath.to_string packages_dir) in 124 124 - match Eio.Path.kind ~follow:true eio_path with 125 125 - | `Directory -> Ok () 126 126 - | _ -> Error (Not_an_opam_repo path) 127 127 - | exception _ -> Error (Not_an_opam_repo path) 128 128 - in 129 129 - let ( let* ) = Result.bind in 130 130 - (* Check all paths are absolute first *) 131 131 - let* () = check_absolute "opam_repo" t.opam_repo in 132 132 - let* () = check_absolute "checkouts" t.checkouts in 133 133 - let* () = check_absolute "monorepo" t.monorepo in 134 134 - (* Then check opam_repo exists and is valid *) 135 135 - let* () = check_dir "opam_repo" t.opam_repo in 136 136 - let* () = check_opam_repo t.opam_repo in 137 137 - Ok t 243 243 + (** {1 Loading and Saving} *) 138 244 139 139 - let load ~fs ~root_fs path = 140 140 - try 141 141 - let config = Tomlt_eio.decode_path_exn codec ~fs (Fpath.to_string path) in 142 142 - validate ~fs:root_fs config 143 143 - |> Result.map_error (fun e -> Fmt.str "%a" pp_validation_error e) 144 144 - with 145 145 - | Eio.Io _ as e -> Error (Printexc.to_string e) 146 146 - | Failure msg -> Error (Fmt.str "Invalid config: %s" msg) 147 147 - 148 148 - let load_xdg ~xdg () = 149 149 - let config_dir = Xdge.config_dir xdg in 150 150 - let config_path = Eio.Path.(config_dir / "config.toml") in 151 151 - try 152 152 - let config = 153 153 - Tomlt_eio.decode_path_exn codec ~fs:config_dir (snd config_path) 154 154 - in 155 155 - let dir, _ = config_dir in 156 156 - validate ~fs:(dir, "") config 157 157 - |> Result.map_error (fun e -> Fmt.str "%a" pp_validation_error e) 158 158 - with 159 159 - | Eio.Io _ as e -> Error (Printexc.to_string e) 160 160 - | Failure msg -> Error (Fmt.str "Invalid config: %s" msg) 245 245 + let load ~fs () = 246 246 + let path = config_file () in 247 247 + let path_str = Fpath.to_string path in 248 248 + let eio_path = Eio.Path.(fs / path_str) in 249 249 + match Eio.Path.kind ~follow:true eio_path with 250 250 + | `Regular_file -> ( 251 251 + try Ok (Tomlt_eio.decode_path_exn codec ~fs path_str) with 252 252 + | Failure msg -> Error (Printf.sprintf "Invalid config: %s" msg) 253 253 + | exn -> Error (Printf.sprintf "Error loading config: %s" (Printexc.to_string exn))) 254 254 + | _ -> Error (Printf.sprintf "Config file not found: %s" path_str) 255 255 + | exception _ -> Error (Printf.sprintf "Config file not found: %s" path_str) 161 256 162 162 - let save ~fs t path = 257 257 + let save ~fs t = 258 258 + let dir = config_dir () in 259 259 + let path = config_file () in 163 260 try 261 261 + (* Ensure XDG config directory exists *) 262 262 + let dir_path = Eio.Path.(fs / Fpath.to_string dir) in 263 263 + (try Eio.Path.mkdirs ~perm:0o755 dir_path with Eio.Io _ -> ()); 164 264 Tomlt_eio.encode_path codec t ~fs (Fpath.to_string path); 165 265 Ok () 166 266 with Eio.Io _ as e -> Error (Printexc.to_string e) 167 267 268 268 + (** {1 Pretty Printing} *) 269 269 + 168 270 let pp ppf t = 169 271 Fmt.pf ppf 170 170 - "@[<v>@[<hov 2>paths:@ opam_repo=%a@ checkouts=%a@ monorepo=%a@]@,\ 171 171 - default_branch=%s@,\ 272 272 + "@[<v>@[<hov 2>workspace:@ root=%a@]@,\ 273 273 + @[<hov 2>identity:@ handle=%s@ knot=%s@]@,\ 274 274 + @[<hov 2>paths:@ mono=%s@ src=%s@ verse=%s@]@,\ 172 275 packages=%d@]" 173 173 - Fpath.pp t.opam_repo Fpath.pp t.checkouts Fpath.pp t.monorepo 174 174 - t.default_branch (List.length t.packages) 276 276 + Fpath.pp t.root t.handle t.knot 277 277 + t.paths.mono t.paths.src t.paths.verse 278 278 + (List.length t.packages)

+121 -67

lib/config.mli

reviewed

··· 1 1 - (** Configuration management for monopam. 1 1 + (** Unified configuration for monopam. 2 2 3 3 - Configuration is stored in TOML format and loaded from XDG standard 4 4 - locations or a user-specified path. The config file specifies paths to the 5 5 - opam overlay, individual checkouts, and the monorepo, along with optional 6 6 - per-package overrides. *) 3 3 + Configuration is stored in TOML format at [~/.config/monopam/opamverse.toml]. 4 4 + 5 5 + The config stores: 6 6 + - Workspace root and custom paths 7 7 + - User identity (handle, knot) 8 8 + - Per-package overrides 9 9 + 10 10 + Standard paths derived from root: 11 11 + - [mono/] - user's monorepo 12 12 + - [src/] - git checkouts for subtrees 13 13 + - [opam-repo/] - opam overlay repository 14 14 + - [verse/] - other members' monorepos *) 7 15 8 16 (** {1 Types} *) 9 17 ··· 16 24 (** [branch t] returns the branch override for this package, if set. *) 17 25 end 18 26 27 27 + (** Configurable paths within the workspace. 28 28 + 29 29 + By default, paths are: 30 30 + - [mono = "mono"] - monorepo directory 31 31 + - [src = "src"] - source checkouts directory 32 32 + - [verse = "verse"] - verse directory 33 33 + 34 34 + Set [mono = "."] to have packages at the root level. *) 35 35 + type paths = { 36 36 + mono : string; (** Monorepo directory (default: "mono") *) 37 37 + src : string; (** Source checkouts directory (default: "src") *) 38 38 + verse : string; (** Verse directory (default: "verse") *) 39 39 + } 40 40 + 41 41 + val default_paths : paths 42 42 + (** Default paths configuration. *) 43 43 + 19 44 type t 20 45 (** The main configuration. *) 21 46 22 22 - (** {1 Paths Configuration} *) 47 47 + (** {1 Accessors} *) 23 48 24 24 - (** Path-related accessors. *) 25 25 - module Paths : sig 26 26 - val opam_repo : t -> Fpath.t 27 27 - (** [opam_repo t] returns the path to the opam overlay repository. *) 28 28 - 29 29 - val checkouts : t -> Fpath.t 30 30 - (** [checkouts t] returns the parent directory where individual package 31 31 - checkouts are stored. *) 49 49 + val root : t -> Fpath.t 50 50 + (** [root t] returns the workspace root directory. *) 32 51 33 33 - val monorepo : t -> Fpath.t 34 34 - (** [monorepo t] returns the path to the monorepo directory. *) 35 35 - end 52 52 + val handle : t -> string 53 53 + (** [handle t] returns the user's handle. *) 36 54 37 37 - (** {1 Options} *) 55 55 + val knot : t -> string 56 56 + (** [knot t] returns the git push server hostname (e.g., "git.recoil.org"). 57 57 + Used for converting tangled URLs to SSH push URLs. *) 38 58 39 39 - val default_branch : t -> string 40 40 - (** [default_branch t] returns the default git branch to track. 59 59 + val paths : t -> paths 60 60 + (** [paths t] returns the paths configuration. *) 41 61 42 42 - Defaults to "main" if not specified. *) 62 62 + val packages : t -> (string * Package_config.t) list 63 63 + (** [packages t] returns the list of package overrides. *) 43 64 44 65 val package_config : t -> string -> Package_config.t option 45 66 (** [package_config t name] returns package-specific configuration overrides for 46 67 the named package, if any exist. *) 47 68 48 48 - (** {1 Validation} *) 69 69 + (** {1 Derived Paths} *) 49 70 50 50 - (** Errors that can occur when validating configuration paths. *) 51 51 - type validation_error = 52 52 - | Path_not_found of string * Fpath.t (** A configured path does not exist *) 53 53 - | Not_a_directory of string * Fpath.t 54 54 - (** A configured path is not a directory *) 55 55 - | Not_an_opam_repo of Fpath.t 56 56 - (** The opam_repo path is not a valid opam repository (missing packages/ 57 57 - directory) *) 58 58 - | Invalid_path of string * string (** A path string could not be parsed *) 59 59 - | Relative_path of string * Fpath.t 60 60 - (** A configured path is relative but must be absolute *) 71 71 + val default_branch : string 72 72 + (** Default git branch, always ["main"]. *) 61 73 62 62 - val pp_validation_error : validation_error Fmt.t 63 63 - (** [pp_validation_error] formats validation errors. *) 74 74 + val mono_path : t -> Fpath.t 75 75 + (** [mono_path t] returns the path to the user's monorepo. *) 64 76 65 65 - (** {1 Loading and Saving} *) 77 77 + val src_path : t -> Fpath.t 78 78 + (** [src_path t] returns the path to git checkouts. *) 66 79 67 67 - val load : 68 68 - fs:_ Eio.Path.t -> root_fs:_ Eio.Path.t -> Fpath.t -> (t, string) result 69 69 - (** [load ~fs ~root_fs path] loads configuration from the specified TOML file. 80 80 + val opam_repo_path : t -> Fpath.t 81 81 + (** [opam_repo_path t] returns the path to the opam overlay. *) 70 82 71 71 - Validates that paths exist and are valid. Supports tilde expansion for paths 72 72 - (e.g., [~/src/...]). 83 83 + val verse_path : t -> Fpath.t 84 84 + (** [verse_path t] returns the path to tracked members' monorepos. *) 73 85 74 74 - @param fs The filesystem path for locating the config file 75 75 - @param root_fs The root filesystem for validating absolute paths in config 86 86 + (** {1 Backwards Compatibility} *) 76 87 77 77 - Returns [Error msg] if the file cannot be read, parsed, or if validation 78 78 - fails. *) 88 88 + (** Path accessors using old naming convention. *) 89 89 + module Paths : sig 90 90 + val opam_repo : t -> Fpath.t 91 91 + (** Alias for [opam_repo_path]. *) 79 92 80 80 - val load_xdg : xdg:Xdge.t -> unit -> (t, string) result 81 81 - (** [load_xdg ~xdg ()] loads configuration from XDG standard locations. 93 93 + val checkouts : t -> Fpath.t 94 94 + (** Alias for [src_path]. *) 82 95 83 83 - Searches for "config.toml" in the monopam XDG config directory. Validates 84 84 - that paths exist and are valid. Supports tilde expansion. 96 96 + val monorepo : t -> Fpath.t 97 97 + (** Alias for [mono_path]. *) 98 98 + end 99 99 + 100 100 + (** {1 XDG Paths} *) 101 101 + 102 102 + val config_dir : unit -> Fpath.t 103 103 + (** [config_dir ()] returns the XDG config directory for monopam 104 104 + (~/.config/monopam). *) 105 105 + 106 106 + val data_dir : unit -> Fpath.t 107 107 + (** [data_dir ()] returns the XDG data directory for monopam 108 108 + (~/.local/share/monopam). *) 85 109 86 86 - Returns [Error msg] if no config file is found, parsing fails, or if 87 87 - validation fails. 110 110 + val cache_dir : unit -> Fpath.t 111 111 + (** [cache_dir ()] returns the XDG cache directory for monopam 112 112 + (~/.cache/monopam). *) 88 113 89 89 - @param xdg The Xdge context for "monopam" application *) 114 114 + val config_file : unit -> Fpath.t 115 115 + (** [config_file ()] returns the path to the config file 116 116 + (~/.config/monopam/opamverse.toml). *) 90 117 91 91 - val save : fs:_ Eio.Path.t -> t -> Fpath.t -> (unit, string) result 92 92 - (** [save ~fs t path] writes the configuration to the specified path. *) 118 118 + val registry_path : unit -> Fpath.t 119 119 + (** [registry_path ()] returns the path to the cloned registry git repo 120 120 + (~/.local/share/monopam/opamverse-registry). *) 93 121 94 122 (** {1 Construction} *) 95 123 96 124 val create : 97 97 - opam_repo:Fpath.t -> 98 98 - checkouts:Fpath.t -> 99 99 - monorepo:Fpath.t -> 100 100 - ?default_branch:string -> 125 125 + root:Fpath.t -> 126 126 + handle:string -> 127 127 + ?knot:string -> 128 128 + ?packages:(string * Package_config.t) list -> 129 129 + ?paths:paths -> 101 130 unit -> 102 131 t 103 103 - (** [create ~opam_repo ~checkouts ~monorepo ?default_branch ()] creates a new 104 104 - configuration with the specified paths. 132 132 + (** [create ~root ~handle ?knot ?packages ?paths ()] creates a new configuration. 133 133 + 134 134 + @param root Workspace root directory (absolute path) 135 135 + @param handle User's handle 136 136 + @param knot Git push server hostname. If not provided, derived from handle 137 137 + @param packages Optional list of package overrides 138 138 + @param paths Optional custom paths configuration *) 139 139 + 140 140 + val with_package_override : t -> name:string -> ?branch:string -> unit -> t 141 141 + (** [with_package_override t ~name ?branch ()] returns a new config 142 142 + with overrides for the named package. *) 143 143 + 144 144 + (** {1 Validation} *) 145 145 + 146 146 + type validation_error = 147 147 + | Path_not_found of string * Fpath.t 148 148 + | Not_a_directory of string * Fpath.t 149 149 + | Not_an_opam_repo of Fpath.t 150 150 + | Invalid_path of string * string 151 151 + | Relative_path of string * Fpath.t 152 152 + 153 153 + val pp_validation_error : validation_error Fmt.t 154 154 + (** [pp_validation_error] formats validation errors. *) 155 155 + 156 156 + (** {1 Loading and Saving} *) 157 157 + 158 158 + val load : fs:_ Eio.Path.t -> unit -> (t, string) result 159 159 + (** [load ~fs ()] loads the configuration from the XDG config file. 160 160 + 161 161 + @param fs Eio filesystem *) 105 162 106 106 - @param opam_repo Path to the opam overlay repository 107 107 - @param checkouts Parent directory for individual git checkouts 108 108 - @param monorepo Path to the monorepo 109 109 - @param default_branch Default branch to track (default: "main") *) 163 163 + val save : fs:_ Eio.Path.t -> t -> (unit, string) result 164 164 + (** [save ~fs config] saves the configuration to the XDG config file. 110 165 111 111 - val with_package_override : t -> name:string -> branch:string -> t 112 112 - (** [with_package_override t ~name ~branch] returns a new config with a branch 113 113 - override for the named package. *) 166 166 + @param fs Eio filesystem 167 167 + @param config Configuration to save *) 114 168 115 169 (** {1 Pretty Printing} *) 116 170

+63 -41

lib/cross_status.ml

reviewed

··· 1 1 (** Cross-user repository comparison for monopam. 2 2 3 3 - Compares subtrees across multiple verse users' monorepos to identify 4 4 - common repositories and their relative commit states. *) 3 3 + Compares subtrees across multiple verse users' monorepos to identify common 4 4 + repositories and their relative commit states. *) 5 5 6 6 (** Relationship between two subtree commits. *) 7 7 type relationship = ··· 12 12 (** Commits have diverged from a common ancestor *) 13 13 | Unknown (** Cannot determine relationship (missing commits, etc.) *) 14 14 15 15 - (** Information about a subtree in a monorepo. *) 16 15 type subtree_info = { 17 16 monorepo_path : Fpath.t; (** Path to the monorepo *) 18 17 prefix : string; (** Subtree directory name *) 19 18 upstream_commit : string option; (** Last synced upstream commit SHA *) 20 19 } 20 20 + (** Information about a subtree in a monorepo. *) 21 21 22 22 - (** Comparison of a repo across multiple users. *) 23 22 type repo_comparison = { 24 23 repo_name : string; (** Repository/subtree name *) 25 25 - my_info : subtree_info option; (** My subtree info (None if not in my mono) *) 24 24 + my_info : subtree_info option; 25 25 + (** My subtree info (None if not in my mono) *) 26 26 others : (string * subtree_info * relationship) list; 27 27 (** List of (handle, info, relationship to me) *) 28 28 } 29 29 + (** Comparison of a repo across multiple users. *) 29 30 30 30 - (** Summary of all cross-user comparisons. *) 31 31 type t = { 32 32 my_repos : repo_comparison list; (** Repos I have, compared against others *) 33 33 other_repos : (string * string list) list; 34 34 (** Repos I don't have: (repo_name, list of handles who have it) *) 35 35 } 36 36 + (** Summary of all cross-user comparisons. *) 36 37 37 38 let pp_relationship ppf = function 38 39 | Same -> Fmt.string ppf "same" 39 39 - | I_am_ahead n -> Fmt.pf ppf "%d behind" n (* They are behind me *) 40 40 - | I_am_behind n -> Fmt.pf ppf "%d ahead" n (* They are ahead of me *) 40 40 + | I_am_ahead n -> Fmt.pf ppf "%d behind" n (* They are behind me *) 41 41 + | I_am_behind n -> Fmt.pf ppf "%d ahead" n (* They are ahead of me *) 41 42 | Diverged { my_ahead; their_ahead } -> 42 43 Fmt.pf ppf "diverged: them +%d, me +%d" their_ahead my_ahead 43 44 | Unknown -> Fmt.string ppf "unknown" 44 45 45 46 let pp_subtree_info ppf info = 46 47 match info.upstream_commit with 47 47 - | Some commit -> Fmt.pf ppf "%s" (String.sub commit 0 (min 7 (String.length commit))) 48 48 + | Some commit -> 49 49 + Fmt.pf ppf "%s" (String.sub commit 0 (min 7 (String.length commit))) 48 50 | None -> Fmt.string ppf "(no commit)" 49 51 50 52 let pp_repo_comparison ppf comp = ··· 54 56 | None -> ()); 55 57 List.iter 56 58 (fun (handle, info, rel) -> 57 57 - Fmt.pf ppf "%-19s %a (%a)@," handle pp_subtree_info info pp_relationship rel) 59 59 + Fmt.pf ppf "%-19s %a (%a)@," handle pp_subtree_info info pp_relationship 60 60 + rel) 58 61 comp.others; 59 62 Fmt.pf ppf "@]" 60 63 ··· 62 65 let pp ppf t = 63 66 if t.my_repos <> [] then begin 64 67 Fmt.pf ppf "@[<v>Cross-user comparison:@,"; 65 65 - List.iter (fun comp -> Fmt.pf ppf " %a@," pp_repo_comparison comp) t.my_repos; 68 68 + List.iter 69 69 + (fun comp -> Fmt.pf ppf " %a@," pp_repo_comparison comp) 70 70 + t.my_repos; 66 71 Fmt.pf ppf "@]" 67 72 end; 68 73 if t.other_repos <> [] then begin ··· 97 102 let with_actions = ref [] in 98 103 let in_sync = ref [] in 99 104 100 100 - List.iter (fun comp -> 101 101 - let actionable = 102 102 - List.filter (fun (_, _, rel) -> is_actionable rel) comp.others 103 103 - in 104 104 - if actionable <> [] then 105 105 - with_actions := (comp, actionable) :: !with_actions 106 106 - else 107 107 - in_sync := comp :: !in_sync) 105 105 + List.iter 106 106 + (fun comp -> 107 107 + let actionable = 108 108 + List.filter (fun (_, _, rel) -> is_actionable rel) comp.others 109 109 + in 110 110 + if actionable <> [] then 111 111 + with_actions := (comp, actionable) :: !with_actions 112 112 + else in_sync := comp :: !in_sync) 108 113 t.my_repos; 109 114 110 115 (* Print repos with actions needed first *) 111 116 if !with_actions <> [] then begin 112 117 Fmt.pf ppf "@[<v>@,Subtrees with upstream changes:@,"; 113 113 - List.iter (fun (comp, actionable) -> 114 114 - let changes = List.map (fun (h, _, rel) -> 115 115 - Fmt.str "%s:%a" h pp_rel_short rel) actionable 116 116 - in 117 117 - Fmt.pf ppf " %-24s %s@," comp.repo_name (String.concat " " changes)) 118 118 + List.iter 119 119 + (fun (comp, actionable) -> 120 120 + let changes = 121 121 + List.map 122 122 + (fun (h, _, rel) -> Fmt.str "%s:%a" h pp_rel_short rel) 123 123 + actionable 124 124 + in 125 125 + Fmt.pf ppf " %-24s %s@," comp.repo_name (String.concat " " changes)) 118 126 (List.rev !with_actions); 119 127 Fmt.pf ppf "@]" 120 128 end; ··· 137 145 in 138 146 { monorepo_path; prefix; upstream_commit } 139 147 140 140 - (** Compare two subtree commits using a reference checkout. 141 141 - If checkout is available, use it as the authoritative source. 142 142 - Otherwise, just check if commits match. *) 148 148 + (** Compare two subtree commits using a reference checkout. If checkout is 149 149 + available, use it as the authoritative source. Otherwise, just check if 150 150 + commits match. *) 143 151 let compare_commits ~proc ~fs ~checkout_path ~my_commit ~their_commit () = 144 152 match (my_commit, their_commit) with 145 153 | None, _ | _, None -> Unknown ··· 150 158 else begin 151 159 (* Check if either is ancestor of the other *) 152 160 let my_is_ancestor = 153 153 - Git.is_ancestor ~proc ~fs ~repo:checkout_path ~commit1:my ~commit2:their () 161 161 + Git.is_ancestor ~proc ~fs ~repo:checkout_path ~commit1:my 162 162 + ~commit2:their () 154 163 in 155 164 let their_is_ancestor = 156 156 - Git.is_ancestor ~proc ~fs ~repo:checkout_path ~commit1:their ~commit2:my () 165 165 + Git.is_ancestor ~proc ~fs ~repo:checkout_path ~commit1:their 166 166 + ~commit2:my () 157 167 in 158 168 match (my_is_ancestor, their_is_ancestor) with 159 169 | true, false -> 160 170 (* My commit is ancestor of theirs -> I'm behind *) 161 171 let behind = 162 162 - Git.count_commits_between ~proc ~fs ~repo:checkout_path ~base:my ~head:their () 172 172 + Git.count_commits_between ~proc ~fs ~repo:checkout_path ~base:my 173 173 + ~head:their () 163 174 in 164 175 I_am_behind behind 165 176 | false, true -> 166 177 (* Their commit is ancestor of mine -> I'm ahead *) 167 178 let ahead = 168 168 - Git.count_commits_between ~proc ~fs ~repo:checkout_path ~base:their ~head:my () 179 179 + Git.count_commits_between ~proc ~fs ~repo:checkout_path 180 180 + ~base:their ~head:my () 169 181 in 170 182 I_am_ahead ahead 171 183 | true, true -> 172 184 (* Both are ancestors of each other -> same commit *) 173 185 Same 174 174 - | false, false -> 186 186 + | false, false -> ( 175 187 (* Neither is ancestor -> diverged *) 176 176 - (match Git.merge_base ~proc ~fs ~repo:checkout_path ~commit1:my ~commit2:their () with 188 188 + match 189 189 + Git.merge_base ~proc ~fs ~repo:checkout_path ~commit1:my 190 190 + ~commit2:their () 191 191 + with 177 192 | Error _ -> Unknown 178 193 | Ok base -> 179 194 let my_ahead = 180 180 - Git.count_commits_between ~proc ~fs ~repo:checkout_path ~base ~head:my () 195 195 + Git.count_commits_between ~proc ~fs ~repo:checkout_path ~base 196 196 + ~head:my () 181 197 in 182 198 let their_ahead = 183 183 - Git.count_commits_between ~proc ~fs ~repo:checkout_path ~base ~head:their () 199 199 + Git.count_commits_between ~proc ~fs ~repo:checkout_path ~base 200 200 + ~head:their () 184 201 in 185 202 Diverged { my_ahead; their_ahead }) 186 203 end 187 204 188 188 - (** Compute cross-user status comparing my monorepo against all verse members. *) 205 205 + (** Compute cross-user status comparing my monorepo against all verse members. 206 206 + *) 189 207 let compute ~proc ~fs ~verse_config ~monopam_config () = 190 208 let my_mono = Verse_config.mono_path verse_config in 191 209 let checkouts = Config.Paths.checkouts monopam_config in ··· 194 212 let my_subtrees = Verse.scan_subtrees ~proc ~fs my_mono in 195 213 196 214 (* Get verse subtrees (map: repo_name -> [(handle, monorepo_path)]) *) 197 197 - let verse_subtrees = Verse.get_verse_subtrees ~proc ~fs ~config:verse_config () in 215 215 + let verse_subtrees = 216 216 + Verse.get_verse_subtrees ~proc ~fs ~config:verse_config () 217 217 + in 198 218 199 219 (* Build comparisons for repos I have *) 200 220 let my_repos = 201 221 List.filter_map 202 222 (fun repo_name -> 203 203 - let my_info = get_subtree_info ~proc ~fs ~monorepo_path:my_mono ~prefix:repo_name () in 223 223 + let my_info = 224 224 + get_subtree_info ~proc ~fs ~monorepo_path:my_mono ~prefix:repo_name () 225 225 + in 204 226 let checkout_path = Fpath.(checkouts / repo_name) in 205 227 206 228 (* Find others who have this repo *) ··· 208 230 try Hashtbl.find verse_subtrees repo_name with Not_found -> [] 209 231 in 210 232 211 211 - if others_with_repo = [] then 212 212 - None (* No one else has this repo, skip *) 233 233 + if others_with_repo = [] then None (* No one else has this repo, skip *) 213 234 else begin 214 235 let others = 215 236 List.map 216 237 (fun (handle, their_mono) -> 217 238 let their_info = 218 218 - get_subtree_info ~proc ~fs ~monorepo_path:their_mono ~prefix:repo_name () 239 239 + get_subtree_info ~proc ~fs ~monorepo_path:their_mono 240 240 + ~prefix:repo_name () 219 241 in 220 242 let rel = 221 243 compare_commits ~proc ~fs ~checkout_path

+11 -10

lib/cross_status.mli

reviewed

··· 1 1 (** Cross-user repository comparison for monopam. 2 2 3 3 - Compares subtrees across multiple verse users' monorepos to identify 4 4 - common repositories and their relative commit states. *) 3 3 + Compares subtrees across multiple verse users' monorepos to identify common 4 4 + repositories and their relative commit states. *) 5 5 6 6 (** {1 Types} *) 7 7 ··· 14 14 (** Commits have diverged from a common ancestor *) 15 15 | Unknown (** Cannot determine relationship (missing commits, etc.) *) 16 16 17 17 - (** Information about a subtree in a monorepo. *) 18 17 type subtree_info = { 19 18 monorepo_path : Fpath.t; (** Path to the monorepo *) 20 19 prefix : string; (** Subtree directory name *) 21 20 upstream_commit : string option; (** Last synced upstream commit SHA *) 22 21 } 22 22 + (** Information about a subtree in a monorepo. *) 23 23 24 24 - (** Comparison of a repo across multiple users. *) 25 24 type repo_comparison = { 26 25 repo_name : string; (** Repository/subtree name *) 27 27 - my_info : subtree_info option; (** My subtree info (None if not in my mono) *) 26 26 + my_info : subtree_info option; 27 27 + (** My subtree info (None if not in my mono) *) 28 28 others : (string * subtree_info * relationship) list; 29 29 (** List of (handle, info, relationship to me) *) 30 30 } 31 31 + (** Comparison of a repo across multiple users. *) 31 32 32 32 - (** Summary of all cross-user comparisons. *) 33 33 type t = { 34 34 my_repos : repo_comparison list; (** Repos I have, compared against others *) 35 35 other_repos : (string * string list) list; 36 36 (** Repos I don't have: (repo_name, list of handles who have it) *) 37 37 } 38 38 + (** Summary of all cross-user comparisons. *) 38 39 39 40 (** {1 Pretty Printing} *) 40 41 ··· 51 52 (** [pp] formats the full cross-user status with commit SHAs. *) 52 53 53 54 val pp_summary : t Fmt.t 54 54 - (** [pp_summary] formats a succinct summary with emphasis on repos where 55 55 - others have commits not in mine. *) 55 55 + (** [pp_summary] formats a succinct summary with emphasis on repos where others 56 56 + have commits not in mine. *) 56 57 57 58 val is_actionable : relationship -> bool 58 58 - (** [is_actionable rel] returns [true] if the relationship indicates 59 59 - that others have commits I should consider pulling (I_am_behind or Diverged). *) 59 59 + (** [is_actionable rel] returns [true] if the relationship indicates that others 60 60 + have commits I should consider pulling (I_am_behind or Diverged). *) 60 61 61 62 (** {1 Computation} *) 62 63

+563 -306

lib/doctor.ml

reviewed

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

+18 -32

lib/doctor.mli

reviewed

··· 1 1 (** Doctor command - Claude-powered workspace health analysis. 2 2 3 3 - Analyzes workspace state, verse member commits, and provides 4 4 - actionable recommendations for maintaining your monorepo. 3 3 + Analyzes workspace state, verse member commits, and provides actionable 4 4 + recommendations for maintaining your monorepo. 5 5 6 6 The doctor command uses Claude AI to analyze commits from verse 7 7 collaborators, categorizing them by type, priority, and risk level. ··· 37 37 | Other 38 38 39 39 (** Priority level for a change *) 40 40 - type priority = 41 41 - | Critical 42 42 - | High 43 43 - | Medium 44 44 - | Low 40 40 + type priority = Critical | High | Medium | Low 45 41 46 42 (** Recommended action for a commit *) 47 47 - type recommendation = 48 48 - | Merge_now 49 49 - | Review_first 50 50 - | Skip 51 51 - | Needs_discussion 43 43 + type recommendation = Merge_now | Review_first | Skip | Needs_discussion 52 44 53 45 (** Risk of conflicts when merging *) 54 54 - type conflict_risk = 55 55 - | None_risk 56 56 - | Low_risk 57 57 - | Medium_risk 58 58 - | High_risk 46 46 + type conflict_risk = None_risk | Low_risk | Medium_risk | High_risk 59 47 60 60 - (** Analysis of a single commit from a verse member *) 61 48 type commit_analysis = { 62 49 hash : string; 63 50 subject : string; ··· 69 56 conflict_risk : conflict_risk; 70 57 commit_summary : string; 71 58 } 59 59 + (** Analysis of a single commit from a verse member *) 72 60 73 73 - (** Analysis of commits from a specific verse member for a repo *) 74 61 type verse_analysis = { 75 62 handle : string; 76 63 commits : commit_analysis list; 77 64 suggested_action : string option; 78 65 } 66 66 + (** Analysis of commits from a specific verse member for a repo *) 79 67 80 80 - (** Sync status for a single repository *) 81 68 type repo_sync = { 82 69 name : string; 83 70 local_sync : [ `In_sync | `Ahead of int | `Behind of int | `Needs_sync ]; ··· 85 72 remote_behind : int; 86 73 verse_analyses : verse_analysis list; 87 74 } 75 75 + (** Sync status for a single repository *) 88 76 89 89 - (** Summary statistics *) 90 77 type report_summary = { 91 78 repos_total : int; 92 79 repos_need_sync : int; 93 80 repos_behind_upstream : int; 94 81 verse_divergences : int; 95 82 } 83 83 + (** Summary statistics *) 96 84 97 97 - (** Actionable recommendation *) 98 85 type action = { 99 86 action_priority : priority; 100 87 description : string; 101 88 command : string option; 102 89 } 90 90 + (** Actionable recommendation *) 103 91 104 104 - (** Full doctor report *) 105 92 type report = { 106 93 timestamp : string; 107 94 workspace : string; ··· 110 97 recommendations : action list; 111 98 warnings : string list; 112 99 } 100 100 + (** Full doctor report *) 113 101 114 102 (** {1 Pretty Printing} *) 115 103 ··· 166 154 By default, runs [monopam sync] first to ensure the workspace is up-to-date 167 155 before analysis. Use [~no_sync:true] to skip the initial sync. 168 156 169 169 - Performs the following analysis: 170 170 - 1. Runs sync to update workspace (unless [~no_sync:true]) 171 171 - 2. Computes status for all packages (or the specified package) 172 172 - 3. Checks for dirty state in opam-repo and monorepo 173 173 - 4. Analyzes fork relationships with verse members 174 174 - 5. Uses Claude AI to categorize and prioritize verse commits 175 175 - 6. Generates actionable recommendations 157 157 + Performs the following analysis: 1. Runs sync to update workspace (unless 158 158 + [~no_sync:true]) 2. Computes status for all packages (or the specified 159 159 + package) 3. Checks for dirty state in opam-repo and monorepo 4. Analyzes 160 160 + fork relationships with verse members 5. Uses Claude AI to categorize and 161 161 + prioritize verse commits 6. Generates actionable recommendations 176 162 177 177 - The status output from [monopam status] is provided directly to Claude 178 178 - in the prompt, so Claude doesn't need to run it separately. 163 163 + The status output from [monopam status] is provided directly to Claude in 164 164 + the prompt, so Claude doesn't need to run it separately. 179 165 180 166 @param proc Eio process manager 181 167 @param fs Eio filesystem

+16 -1

lib/dune

reviewed

··· 1 1 (library 2 2 (name monopam) 3 3 (public_name monopam) 4 4 - (libraries eio tomlt tomlt.eio xdge opam-file-format fmt logs uri fpath claude jsont jsont.bytesrw ptime)) 4 4 + (libraries 5 5 + eio 6 6 + tomlt 7 7 + tomlt.eio 8 8 + xdge 9 9 + opam-file-format 10 10 + fmt 11 11 + logs 12 12 + uri 13 13 + fpath 14 14 + claude 15 15 + jsont 16 16 + jsont.bytesrw 17 17 + ptime 18 18 + sexplib0 19 19 + parsexp))

+148

lib/dune_project.ml

reviewed

··· 1 1 + (** Dune project file parsing. *) 2 2 + 3 3 + type source_info = 4 4 + | Github of { user : string; repo : string } 5 5 + | Gitlab of { user : string; repo : string } 6 6 + | Tangled of { host : string; repo : string } (** tangled.org style sources *) 7 7 + | Uri of { url : string; branch : string option } 8 8 + 9 9 + type t = { 10 10 + name : string; 11 11 + source : source_info option; 12 12 + homepage : string option; 13 13 + packages : string list; 14 14 + } 15 15 + 16 16 + module Sexp = Sexplib0.Sexp 17 17 + 18 18 + (** Extract string from a Sexp.Atom, or None if it's a List *) 19 19 + let atom_string = function 20 20 + | Sexp.Atom s -> Some s 21 21 + | Sexp.List _ -> None 22 22 + 23 23 + (** Parse source stanza: (source (github user/repo)) or (source (uri "url")) *) 24 24 + let parse_source_inner sexp = 25 25 + match sexp with 26 26 + | Sexp.List [ Sexp.Atom "github"; Sexp.Atom user_repo ] -> ( 27 27 + match String.split_on_char '/' user_repo with 28 28 + | [ user; repo ] -> Some (Github { user; repo }) 29 29 + | _ -> None) 30 30 + | Sexp.List [ Sexp.Atom "gitlab"; Sexp.Atom user_repo ] -> ( 31 31 + match String.split_on_char '/' user_repo with 32 32 + | [ user; repo ] -> Some (Gitlab { user; repo }) 33 33 + | _ -> None) 34 34 + | Sexp.List [ Sexp.Atom "tangled"; Sexp.Atom host_repo ] -> ( 35 35 + (* tangled sources: (tangled host.domain/repo) *) 36 36 + match String.index_opt host_repo '/' with 37 37 + | Some i -> 38 38 + let host = String.sub host_repo 0 i in 39 39 + let repo = String.sub host_repo (i + 1) (String.length host_repo - i - 1) in 40 40 + Some (Tangled { host; repo }) 41 41 + | None -> None) 42 42 + | Sexp.List [ Sexp.Atom "uri"; Sexp.Atom url ] -> 43 43 + (* Check for branch in URI fragment *) 44 44 + let uri = Uri.of_string url in 45 45 + let branch = Uri.fragment uri in 46 46 + let url_without_fragment = 47 47 + Uri.with_fragment uri None |> Uri.to_string 48 48 + in 49 49 + Some (Uri { url = url_without_fragment; branch }) 50 50 + | Sexp.Atom url -> 51 51 + (* Single atom URL (unlikely but handle it) *) 52 52 + let uri = Uri.of_string url in 53 53 + let branch = Uri.fragment uri in 54 54 + let url_without_fragment = 55 55 + Uri.with_fragment uri None |> Uri.to_string 56 56 + in 57 57 + Some (Uri { url = url_without_fragment; branch }) 58 58 + | _ -> None 59 59 + 60 60 + (** Find name in (package (name foo) ...) stanza *) 61 61 + let rec find_package_name = function 62 62 + | [] -> None 63 63 + | Sexp.List [ Sexp.Atom "name"; Sexp.Atom name ] :: _ -> Some name 64 64 + | _ :: rest -> find_package_name rest 65 65 + 66 66 + (** Extract all package names from parsed sexps *) 67 67 + let extract_packages sexps = 68 68 + List.filter_map 69 69 + (function 70 70 + | Sexp.List (Sexp.Atom "package" :: rest) -> find_package_name rest 71 71 + | _ -> None) 72 72 + sexps 73 73 + 74 74 + (** Find a simple string field like (name foo) or (homepage "url") *) 75 75 + let find_string_field name sexps = 76 76 + List.find_map 77 77 + (function 78 78 + | Sexp.List [ Sexp.Atom n; value ] when n = name -> atom_string value 79 79 + | _ -> None) 80 80 + sexps 81 81 + 82 82 + (** Find source field: (source ...) *) 83 83 + let find_source sexps = 84 84 + List.find_map 85 85 + (function 86 86 + | Sexp.List [ Sexp.Atom "source"; inner ] -> parse_source_inner inner 87 87 + | _ -> None) 88 88 + sexps 89 89 + 90 90 + let parse content = 91 91 + match Parsexp.Many.parse_string content with 92 92 + | Error err -> 93 93 + Error (Printf.sprintf "S-expression parse error: %s" 94 94 + (Parsexp.Parse_error.message err)) 95 95 + | Ok sexps -> ( 96 96 + match find_string_field "name" sexps with 97 97 + | None -> Error "dune-project missing (name ...) stanza" 98 98 + | Some name -> 99 99 + let source = find_source sexps in 100 100 + let homepage = find_string_field "homepage" sexps in 101 101 + let packages = extract_packages sexps in 102 102 + Ok { name; source; homepage; packages }) 103 103 + 104 104 + (** Normalize a URL to have git+ prefix *) 105 105 + let normalize_git_url url = 106 106 + if String.starts_with ~prefix:"git+" url then url 107 107 + else if String.starts_with ~prefix:"git@" url then "git+" ^ url 108 108 + else if String.starts_with ~prefix:"https://" url then "git+" ^ url 109 109 + else if String.starts_with ~prefix:"http://" url then 110 110 + "git+https" ^ String.sub url 4 (String.length url - 4) 111 111 + else "git+" ^ url 112 112 + 113 113 + (** Ensure URL ends with .git *) 114 114 + let ensure_git_suffix url = 115 115 + if String.ends_with ~suffix:".git" url then url 116 116 + else url ^ ".git" 117 117 + 118 118 + let dev_repo_url t = 119 119 + match t.source with 120 120 + | Some (Github { user; repo }) -> 121 121 + Ok (Printf.sprintf "git+https://github.com/%s/%s.git" user repo) 122 122 + | Some (Gitlab { user; repo }) -> 123 123 + Ok (Printf.sprintf "git+https://gitlab.com/%s/%s.git" user repo) 124 124 + | Some (Tangled { host; repo }) -> 125 125 + (* Tangled sources: https://tangled.sh/@handle/repo *) 126 126 + Ok (Printf.sprintf "git+https://tangled.sh/@%s/%s.git" host repo) 127 127 + | Some (Uri { url; _ }) -> 128 128 + Ok (normalize_git_url (ensure_git_suffix url)) 129 129 + | None -> ( 130 130 + match t.homepage with 131 131 + | Some homepage -> 132 132 + Ok (normalize_git_url (ensure_git_suffix homepage)) 133 133 + | None -> 134 134 + Error 135 135 + (Printf.sprintf 136 136 + "Package %s must declare source or homepage in dune-project" 137 137 + t.name)) 138 138 + 139 139 + let url_with_branch t = 140 140 + match dev_repo_url t with 141 141 + | Error e -> Error e 142 142 + | Ok url -> 143 143 + let branch = 144 144 + match t.source with 145 145 + | Some (Uri { branch = Some b; _ }) -> b 146 146 + | _ -> "main" 147 147 + in 148 148 + Ok (url ^ "#" ^ branch)

+42

lib/dune_project.mli

reviewed

··· 1 1 + (** Dune project file parsing. 2 2 + 3 3 + Parse dune-project s-expressions to extract package metadata needed 4 4 + for generating opam-repo entries. *) 5 5 + 6 6 + (** Source information from dune-project. *) 7 7 + type source_info = 8 8 + | Github of { user : string; repo : string } 9 9 + | Gitlab of { user : string; repo : string } 10 10 + | Tangled of { host : string; repo : string } (** tangled.sh style sources *) 11 11 + | Uri of { url : string; branch : string option } 12 12 + 13 13 + (** Parsed dune-project file. *) 14 14 + type t = { 15 15 + name : string; (** Project name from (name ...) stanza *) 16 16 + source : source_info option; (** Source from (source ...) stanza *) 17 17 + homepage : string option; (** Homepage from (homepage ...) stanza *) 18 18 + packages : string list; (** Package names from (package (name ...)) stanzas *) 19 19 + } 20 20 + 21 21 + val parse : string -> (t, string) result 22 22 + (** [parse content] parses a dune-project file content and extracts metadata. 23 23 + Returns [Error msg] if parsing fails or required fields are missing. *) 24 24 + 25 25 + val dev_repo_url : t -> (string, string) result 26 26 + (** [dev_repo_url t] derives the dev-repo URL from the parsed dune-project. 27 27 + Returns a URL suitable for the opam dev-repo field (e.g., "git+https://..."). 28 28 + 29 29 + URL derivation logic: 30 30 + - [Github {user; repo}] -> "git+https://github.com/user/repo.git" 31 31 + - [Gitlab {user; repo}] -> "git+https://gitlab.com/user/repo.git" 32 32 + - [Uri {url; _}] -> url normalized with git+ prefix 33 33 + - No source but homepage present -> homepage normalized with git+ prefix 34 34 + - Neither source nor homepage -> Error *) 35 35 + 36 36 + val url_with_branch : t -> (string, string) result 37 37 + (** [url_with_branch t] derives the URL with branch fragment for the opam url section. 38 38 + Returns a URL with #branch suffix (e.g., "git+https://...#main"). 39 39 + 40 40 + Branch derivation: 41 41 + - [Uri {url; branch = Some b}] -> url#b 42 42 + - Otherwise -> url#main *)

+1 -1

lib/feature.ml

reviewed

··· 16 16 Some (Printf.sprintf "Run 'monopam feature remove %s' first if you want to recreate it" name) 17 17 | Feature_not_found name -> 18 18 Some (Printf.sprintf "Run 'monopam feature list' to see available features, or 'monopam feature add %s' to create it" name) 19 19 - | Config_error _ -> Some "Run 'monopam verse init' to create a workspace configuration" 19 19 + | Config_error _ -> Some "Run 'monopam init' to create a workspace configuration" 20 20 21 21 let pp_error_with_hint ppf e = 22 22 pp_error ppf e;

+977

lib/fork_join.ml

reviewed

··· 1 1 + (** Fork and join operations for managing monorepo sources. *) 2 2 + 3 3 + type error = 4 4 + | Config_error of string 5 5 + | Git_error of Git.error 6 6 + | Subtree_not_found of string 7 7 + | Src_already_exists of string 8 8 + | Src_not_found of string 9 9 + | Subtree_already_exists of string 10 10 + | No_opam_files of string 11 11 + | Verse_error of Verse.error 12 12 + | User_cancelled 13 13 + 14 14 + (** {1 Action Types} *) 15 15 + 16 16 + (** An action to be performed during fork/join *) 17 17 + type action = 18 18 + | Check_remote_exists of string (** URL - informational check *) 19 19 + | Create_directory of Fpath.t 20 20 + | Git_init of Fpath.t 21 21 + | Git_config of { repo: Fpath.t; key: string; value: string } (** Set git config *) 22 22 + | Git_clone of { url: string; dest: Fpath.t; branch: string } 23 23 + | Git_subtree_split of { repo: Fpath.t; prefix: string } 24 24 + | Git_subtree_add of { repo: Fpath.t; prefix: string; url: Uri.t; branch: string } 25 25 + | Git_add_remote of { repo: Fpath.t; name: string; url: string } 26 26 + | Git_push_ref of { repo: Fpath.t; target: string; ref_spec: string } 27 27 + | Git_checkout of { repo: Fpath.t; branch: string } 28 28 + | Git_branch_rename of { repo: Fpath.t; new_name: string } (** Rename current branch *) 29 29 + | Copy_directory of { src: Fpath.t; dest: Fpath.t } 30 30 + | Git_add_all of Fpath.t 31 31 + | Git_commit of { repo: Fpath.t; message: string } 32 32 + | Git_rm of { repo: Fpath.t; path: string; recursive: bool } (** Remove file/dir from git *) 33 33 + | Update_sources_toml of { path: Fpath.t; name: string; entry: Sources_registry.entry } 34 34 + 35 35 + (** Discovery information gathered during planning *) 36 36 + type discovery = { 37 37 + mono_exists: bool; 38 38 + src_exists: bool; 39 39 + has_subtree_history: bool; (** Can we git subtree split? *) 40 40 + remote_accessible: bool option; (** None = not checked, Some = result *) 41 41 + opam_files: string list; 42 42 + local_path_is_repo: bool option; (** For join from local dir *) 43 43 + } 44 44 + 45 45 + (** A complete action plan *) 46 46 + type 'a action_plan = { 47 47 + discovery: discovery; 48 48 + actions: action list; 49 49 + result: 'a; (** What we'll return on success *) 50 50 + dry_run: bool; 51 51 + } 52 52 + 53 53 + let pp_error ppf = function 54 54 + | Config_error msg -> Fmt.pf ppf "Configuration error: %s" msg 55 55 + | Git_error e -> Fmt.pf ppf "Git error: %a" Git.pp_error e 56 56 + | Subtree_not_found name -> Fmt.pf ppf "Subtree not found in monorepo: %s" name 57 57 + | Src_already_exists name -> Fmt.pf ppf "Source checkout already exists: src/%s" name 58 58 + | Src_not_found name -> Fmt.pf ppf "Source checkout not found: src/%s" name 59 59 + | Subtree_already_exists name -> Fmt.pf ppf "Subtree already exists in monorepo: mono/%s" name 60 60 + | No_opam_files name -> Fmt.pf ppf "No .opam files found in subtree: %s" name 61 61 + | Verse_error e -> Fmt.pf ppf "Verse error: %a" Verse.pp_error e 62 62 + | User_cancelled -> Fmt.pf ppf "Operation cancelled by user" 63 63 + 64 64 + let error_hint = function 65 65 + | Config_error _ -> 66 66 + Some "Run 'monopam init --handle <your-handle>' to create a workspace." 67 67 + | Git_error (Git.Dirty_worktree _) -> 68 68 + Some "Commit or stash your changes first: git status" 69 69 + | Git_error _ -> None 70 70 + | Subtree_not_found name -> 71 71 + Some (Fmt.str "Check that mono/%s exists in your monorepo" name) 72 72 + | Src_already_exists name -> 73 73 + Some (Fmt.str "Remove or rename src/%s first, or choose a different name" name) 74 74 + | Src_not_found name -> 75 75 + Some (Fmt.str "Run 'monopam fork %s' first to create src/%s" name name) 76 76 + | Subtree_already_exists name -> 77 77 + Some (Fmt.str "Remove mono/%s first, or use a different name with --as" name) 78 78 + | No_opam_files name -> 79 79 + Some (Fmt.str "Add a .opam file to mono/%s before forking" name) 80 80 + | Verse_error e -> Verse.error_hint e 81 81 + | User_cancelled -> None 82 82 + 83 83 + (** {1 Pretty Printers for Actions and Discovery} *) 84 84 + 85 85 + let pp_action ppf = function 86 86 + | Check_remote_exists url -> 87 87 + Fmt.pf ppf "Check remote accessible: %s" url 88 88 + | Create_directory path -> 89 89 + Fmt.pf ppf "Create directory: %a" Fpath.pp path 90 90 + | Git_init path -> 91 91 + Fmt.pf ppf "Initialize git repository: %a" Fpath.pp path 92 92 + | Git_config { repo = _; key; value } -> 93 93 + Fmt.pf ppf "Set git config %s = %s" key value 94 94 + | Git_clone { url; dest; branch } -> 95 95 + Fmt.pf ppf "Clone %s (branch: %s) to %a" url branch Fpath.pp dest 96 96 + | Git_subtree_split { repo = _; prefix } -> 97 97 + Fmt.pf ppf "Split subtree history for '%s'" prefix 98 98 + | Git_subtree_add { repo = _; prefix; url; branch } -> 99 99 + Fmt.pf ppf "Add subtree '%s' from %s (branch: %s)" prefix (Uri.to_string url) branch 100 100 + | Git_add_remote { repo = _; name; url } -> 101 101 + Fmt.pf ppf "Add remote '%s' -> %s" name url 102 102 + | Git_push_ref { repo = _; target; ref_spec } -> 103 103 + Fmt.pf ppf "Push %s to %s" ref_spec target 104 104 + | Git_checkout { repo = _; branch } -> 105 105 + Fmt.pf ppf "Checkout branch '%s'" branch 106 106 + | Git_branch_rename { repo = _; new_name } -> 107 107 + Fmt.pf ppf "Rename current branch to '%s'" new_name 108 108 + | Copy_directory { src; dest } -> 109 109 + Fmt.pf ppf "Copy files from %a to %a" Fpath.pp src Fpath.pp dest 110 110 + | Git_add_all path -> 111 111 + Fmt.pf ppf "Stage all changes in %a" Fpath.pp path 112 112 + | Git_commit { repo = _; message } -> 113 113 + Fmt.pf ppf "Create commit: %s" message 114 114 + | Git_rm { repo = _; path; recursive = _ } -> 115 115 + Fmt.pf ppf "Remove '%s' from git" path 116 116 + | Update_sources_toml { path = _; name; entry = _ } -> 117 117 + Fmt.pf ppf "Update sources.toml for '%s'" name 118 118 + 119 119 + let pp_discovery ppf d = 120 120 + Fmt.pf ppf "@[<v>"; 121 121 + Fmt.pf ppf " mono/<name>/: %s@," 122 122 + (if d.mono_exists then "exists" else "does not exist"); 123 123 + Fmt.pf ppf " src/<name>/: %s@," 124 124 + (if d.src_exists then "exists" else "does not exist"); 125 125 + Fmt.pf ppf " Subtree history: %s@," 126 126 + (if d.has_subtree_history then "present" else "none (fresh package)"); 127 127 + (match d.remote_accessible with 128 128 + | None -> () 129 129 + | Some true -> Fmt.pf ppf " Remote accessible: yes@," 130 130 + | Some false -> Fmt.pf ppf " Remote accessible: no@,"); 131 131 + (match d.local_path_is_repo with 132 132 + | None -> () 133 133 + | Some true -> Fmt.pf ppf " Is git repo: yes@," 134 134 + | Some false -> Fmt.pf ppf " Is git repo: no@,"); 135 135 + if d.opam_files <> [] then 136 136 + Fmt.pf ppf " Packages found: %a@," Fmt.(list ~sep:(any ", ") string) d.opam_files; 137 137 + Fmt.pf ppf "@]" 138 138 + 139 139 + let pp_action_plan : type a. a Fmt.t -> a action_plan Fmt.t = fun pp_result ppf plan -> 140 140 + Fmt.pf ppf "@[<v>Discovery:@,%a@,@,Actions to perform:@," pp_discovery plan.discovery; 141 141 + List.iteri (fun i action -> 142 142 + Fmt.pf ppf " %d. %a@," (i + 1) pp_action action 143 143 + ) plan.actions; 144 144 + if plan.dry_run then 145 145 + Fmt.pf ppf "@,(dry-run mode - no changes will be made)@,"; 146 146 + Fmt.pf ppf "@,Expected result:@, %a@]" pp_result plan.result 147 147 + 148 148 + let pp_error_with_hint ppf e = 149 149 + pp_error ppf e; 150 150 + match error_hint e with 151 151 + | Some hint -> Fmt.pf ppf "@.@[<v 2>Hint: %s@]" hint 152 152 + | None -> () 153 153 + 154 154 + type fork_result = { 155 155 + name : string; 156 156 + split_commit : string; 157 157 + src_path : Fpath.t; 158 158 + push_url : string option; 159 159 + packages_created : string list; 160 160 + } 161 161 + 162 162 + type join_result = { 163 163 + name : string; 164 164 + source_url : string; 165 165 + upstream_url : string option; 166 166 + packages_added : string list; 167 167 + from_handle : string option; 168 168 + } 169 169 + 170 170 + let pp_fork_result ppf (r : fork_result) = 171 171 + (* Only truncate if it looks like a git SHA (40 hex chars), otherwise show full string *) 172 172 + let commit_display = 173 173 + if String.length r.split_commit = 40 && 174 174 + String.for_all (fun c -> (c >= '0' && c <= '9') || (c >= 'a' && c <= 'f')) r.split_commit 175 175 + then String.sub r.split_commit 0 7 176 176 + else r.split_commit 177 177 + in 178 178 + Fmt.pf ppf "@[<v>Forked subtree '%s':@, Split commit: %s@, Local repo: %a@," 179 179 + r.name commit_display Fpath.pp r.src_path; 180 180 + (match r.push_url with 181 181 + | Some url -> Fmt.pf ppf " Push URL: %s@," url 182 182 + | None -> ()); 183 183 + if r.packages_created <> [] then 184 184 + Fmt.pf ppf " Packages: %a@]" Fmt.(list ~sep:(any ", ") string) r.packages_created 185 185 + else 186 186 + Fmt.pf ppf "@]" 187 187 + 188 188 + let pp_join_result ppf (r : join_result) = 189 189 + Fmt.pf ppf "@[<v>Joined repository '%s':@, Source: %s@," 190 190 + r.name r.source_url; 191 191 + (match r.upstream_url with 192 192 + | Some url -> Fmt.pf ppf " Upstream: %s@," url 193 193 + | None -> ()); 194 194 + (match r.from_handle with 195 195 + | Some h -> Fmt.pf ppf " From verse: %s@," h 196 196 + | None -> ()); 197 197 + if r.packages_added <> [] then 198 198 + Fmt.pf ppf " Packages: %a@]" Fmt.(list ~sep:(any ", ") string) r.packages_added 199 199 + else 200 200 + Fmt.pf ppf "@]" 201 201 + 202 202 + (** Helper to check if a path is a directory *) 203 203 + let is_directory ~fs path = 204 204 + let eio_path = Eio.Path.(fs / Fpath.to_string path) in 205 205 + match Eio.Path.kind ~follow:true eio_path with 206 206 + | `Directory -> true 207 207 + | _ -> false 208 208 + | exception _ -> false 209 209 + 210 210 + (** Helper to create a directory if it doesn't exist *) 211 211 + let ensure_dir ~fs path = 212 212 + let eio_path = Eio.Path.(fs / Fpath.to_string path) in 213 213 + try Eio.Path.mkdirs ~perm:0o755 eio_path with Eio.Io _ -> () 214 214 + 215 215 + (** Scan a directory for .opam files *) 216 216 + let find_opam_files ~fs path = 217 217 + let eio_path = Eio.Path.(fs / Fpath.to_string path) in 218 218 + try 219 219 + Eio.Path.read_dir eio_path 220 220 + |> List.filter (fun name -> String.ends_with ~suffix:".opam" name) 221 221 + |> List.map (fun name -> 222 222 + (* Extract package name from filename.opam *) 223 223 + String.sub name 0 (String.length name - 5)) 224 224 + with Eio.Io _ -> [] 225 225 + 226 226 + (** Normalize URL to git+ format for dev-repo *) 227 227 + let normalize_git_url url = 228 228 + if String.starts_with ~prefix:"git+" url then url 229 229 + else if String.starts_with ~prefix:"git://" url then url 230 230 + else if String.starts_with ~prefix:"https://" url then "git+" ^ url 231 231 + else if String.starts_with ~prefix:"http://" url then "git+" ^ url 232 232 + else url 233 233 + 234 234 + (** Check if host is a tangled host *) 235 235 + let is_tangled_host = function 236 236 + | Some "tangled.org" | Some "tangled.sh" -> true 237 237 + | _ -> false 238 238 + 239 239 + (** Convert a dev-repo URL to a push URL (SSH format for github/gitlab/tangled) *) 240 240 + let url_to_push_url ?knot url = 241 241 + (* Strip git+ prefix if present *) 242 242 + let url = 243 243 + if String.starts_with ~prefix:"git+" url then 244 244 + String.sub url 4 (String.length url - 4) 245 245 + else url 246 246 + in 247 247 + let uri = Uri.of_string url in 248 248 + let scheme = Uri.scheme uri in 249 249 + let host = Uri.host uri in 250 250 + let path = Uri.path uri in 251 251 + match (scheme, host) with 252 252 + | Some ("https" | "http"), Some "github.com" -> 253 253 + (* https://github.com/user/repo.git -> git@github.com:user/repo.git *) 254 254 + let path = 255 255 + if String.length path > 0 && path.[0] = '/' then 256 256 + String.sub path 1 (String.length path - 1) 257 257 + else path 258 258 + in 259 259 + Printf.sprintf "git@github.com:%s" path 260 260 + | Some ("https" | "http"), Some "gitlab.com" -> 261 261 + (* https://gitlab.com/user/repo.git -> git@gitlab.com:user/repo.git *) 262 262 + let path = 263 263 + if String.length path > 0 && path.[0] = '/' then 264 264 + String.sub path 1 (String.length path - 1) 265 265 + else path 266 266 + in 267 267 + Printf.sprintf "git@gitlab.com:%s" path 268 268 + | Some ("https" | "http"), _ when is_tangled_host host -> 269 269 + (* https://tangled.sh/@handle/repo -> git@<knot>:handle/repo *) 270 270 + let path = 271 271 + if String.length path > 0 && path.[0] = '/' then 272 272 + String.sub path 1 (String.length path - 1) 273 273 + else path 274 274 + in 275 275 + (* Strip leading @ from handle if present *) 276 276 + let path = 277 277 + if String.length path > 0 && path.[0] = '@' then 278 278 + String.sub path 1 (String.length path - 1) 279 279 + else path 280 280 + in 281 281 + (* Strip .git suffix if present *) 282 282 + let path = 283 283 + if String.ends_with ~suffix:".git" path then 284 284 + String.sub path 0 (String.length path - 4) 285 285 + else path 286 286 + in 287 287 + (* Use provided knot or default to git.recoil.org *) 288 288 + let knot_server = Option.value ~default:"git.recoil.org" knot in 289 289 + Printf.sprintf "git@%s:%s" knot_server path 290 290 + | _ -> 291 291 + (* Return original URL for other cases *) 292 292 + url 293 293 + 294 294 + (** Check if a URL is in the user's own namespace (not a true fork) *) 295 295 + let is_own_namespace ~handle url = 296 296 + (* Extract user/handle from URL and compare with config handle *) 297 297 + let url = 298 298 + if String.starts_with ~prefix:"git+" url then 299 299 + String.sub url 4 (String.length url - 4) 300 300 + else url 301 301 + in 302 302 + (* For SSH URLs like git@github.com:user/repo.git *) 303 303 + if String.starts_with ~prefix:"git@" url then 304 304 + match String.index_opt url ':' with 305 305 + | Some i -> 306 306 + let path = String.sub url (i + 1) (String.length url - i - 1) in 307 307 + (* path is like "user/repo.git" or "handle/repo" *) 308 308 + (match String.index_opt path '/' with 309 309 + | Some j -> 310 310 + let user = String.sub path 0 j in 311 311 + (* Handle may be like "avsm" or "avsm.bsky.social" - compare first component *) 312 312 + let handle_first = 313 313 + match String.index_opt handle '.' with 314 314 + | Some k -> String.sub handle 0 k 315 315 + | None -> handle 316 316 + in 317 317 + String.equal user handle_first || String.equal user handle 318 318 + | None -> false) 319 319 + | None -> false 320 320 + else 321 321 + (* For HTTPS URLs like https://github.com/user/repo.git *) 322 322 + let uri = Uri.of_string url in 323 323 + let path = Uri.path uri in 324 324 + let path = 325 325 + if String.length path > 0 && path.[0] = '/' then 326 326 + String.sub path 1 (String.length path - 1) 327 327 + else path 328 328 + in 329 329 + (* path is like "user/repo.git" or "@handle/repo" *) 330 330 + let path = 331 331 + if String.length path > 0 && path.[0] = '@' then 332 332 + String.sub path 1 (String.length path - 1) 333 333 + else path 334 334 + in 335 335 + match String.index_opt path '/' with 336 336 + | Some j -> 337 337 + let user = String.sub path 0 j in 338 338 + let handle_first = 339 339 + match String.index_opt handle '.' with 340 340 + | Some k -> String.sub handle 0 k 341 341 + | None -> handle 342 342 + in 343 343 + String.equal user handle_first || String.equal user handle 344 344 + | None -> false 345 345 + 346 346 + (** Try to get a suggested push URL from dune-project in the subtree *) 347 347 + let suggest_push_url ~fs ?knot subtree_path = 348 348 + let dune_project_path = Fpath.(subtree_path / "dune-project") in 349 349 + let eio_path = Eio.Path.(fs / Fpath.to_string dune_project_path) in 350 350 + try 351 351 + let content = Eio.Path.load eio_path in 352 352 + match Dune_project.parse content with 353 353 + | Error _ -> None 354 354 + | Ok dune_proj -> 355 355 + match Dune_project.dev_repo_url dune_proj with 356 356 + | Error _ -> None 357 357 + | Ok dev_repo -> Some (url_to_push_url ?knot dev_repo) 358 358 + with Eio.Io _ -> None 359 359 + 360 360 + (** Extract name from URL (last path component without .git suffix) *) 361 361 + let name_from_url url = 362 362 + let uri = Uri.of_string url in 363 363 + let path = Uri.path uri in 364 364 + (* Remove leading slash and .git suffix *) 365 365 + let path = if String.length path > 0 && path.[0] = '/' then 366 366 + String.sub path 1 (String.length path - 1) 367 367 + else path in 368 368 + let path = if String.ends_with ~suffix:".git" path then 369 369 + String.sub path 0 (String.length path - 4) 370 370 + else path in 371 371 + (* Get last component *) 372 372 + match String.rindex_opt path '/' with 373 373 + | Some i -> String.sub path (i + 1) (String.length path - i - 1) 374 374 + | None -> path 375 375 + 376 376 + (** {1 Detection Functions} *) 377 377 + 378 378 + (** Determine if input is a local path or URL *) 379 379 + let is_local_path s = 380 380 + (* It's a URL if it starts with a scheme or looks like SSH URL *) 381 381 + not (String.starts_with ~prefix:"http://" s || 382 382 + String.starts_with ~prefix:"https://" s || 383 383 + String.starts_with ~prefix:"git://" s || 384 384 + String.starts_with ~prefix:"git@" s || 385 385 + String.starts_with ~prefix:"ssh://" s || 386 386 + String.starts_with ~prefix:"git+" s) 387 387 + 388 388 + (** Copy a directory tree recursively *) 389 389 + let copy_directory ~fs ~src ~dest = 390 390 + let src_eio = Eio.Path.(fs / Fpath.to_string src) in 391 391 + let dest_eio = Eio.Path.(fs / Fpath.to_string dest) in 392 392 + let rec copy_rec src_path dest_path = 393 393 + match Eio.Path.kind ~follow:false src_path with 394 394 + | `Directory -> 395 395 + (try Eio.Path.mkdirs ~perm:0o755 dest_path with Eio.Io _ -> ()); 396 396 + List.iter (fun name -> 397 397 + (* Skip .git directory to avoid copying git internals *) 398 398 + if name <> ".git" then begin 399 399 + let src_child = Eio.Path.(src_path / name) in 400 400 + let dest_child = Eio.Path.(dest_path / name) in 401 401 + copy_rec src_child dest_child 402 402 + end 403 403 + ) (Eio.Path.read_dir src_path) 404 404 + | `Regular_file -> 405 405 + let content = Eio.Path.load src_path in 406 406 + Eio.Path.save ~create:(`Or_truncate 0o644) dest_path content 407 407 + | `Symbolic_link -> 408 408 + (* Read symlink target and recreate it *) 409 409 + let target = Eio.Path.read_link src_path in 410 410 + (try Unix.symlink target (snd dest_path) with _ -> ()) 411 411 + | _ -> () (* Skip other file types *) 412 412 + | exception _ -> () 413 413 + in 414 414 + copy_rec src_eio dest_eio 415 415 + 416 416 + (** {1 Plan Builders} *) 417 417 + 418 418 + (** Build a fork plan - handles both subtree and fresh package scenarios. 419 419 + 420 420 + The fork workflow: 421 421 + 1. Create src/<name>/ with the package content (split or copy) 422 422 + 2. Remove mono/<name>/ from git 423 423 + 3. Re-add mono/<name>/ as a proper subtree from src/<name>/ 424 424 + 425 425 + This ensures the subtree relationship is properly established for sync. *) 426 426 + let plan_fork ~proc ~fs ~config ~name ?push_url ?(dry_run = false) () = 427 427 + let monorepo = Verse_config.mono_path config in 428 428 + let checkouts = Verse_config.src_path config in 429 429 + let prefix = name in 430 430 + let subtree_path = Fpath.(monorepo / prefix) in 431 431 + let src_path = Fpath.(checkouts / name) in 432 432 + let branch = Verse_config.default_branch in 433 433 + 434 434 + (* Gather discovery information *) 435 435 + let mono_exists = Git.Subtree.exists ~fs ~repo:monorepo ~prefix in 436 436 + let src_exists = is_directory ~fs src_path in 437 437 + let has_subtree_hist = 438 438 + if mono_exists then Git.has_subtree_history ~proc ~fs ~repo:monorepo ~prefix () 439 439 + else false 440 440 + in 441 441 + let opam_files = 442 442 + if mono_exists then find_opam_files ~fs subtree_path 443 443 + else [] 444 444 + in 445 445 + 446 446 + let discovery = { 447 447 + mono_exists; 448 448 + src_exists; 449 449 + has_subtree_history = has_subtree_hist; 450 450 + remote_accessible = None; (* Could check if push_url is accessible *) 451 451 + opam_files; 452 452 + local_path_is_repo = None; 453 453 + } in 454 454 + 455 455 + (* Validation *) 456 456 + if not mono_exists then 457 457 + Error (Subtree_not_found name) 458 458 + else if src_exists then 459 459 + Error (Src_already_exists name) 460 460 + else if opam_files = [] then 461 461 + Error (No_opam_files name) 462 462 + else begin 463 463 + (* Build actions for complete fork workflow: 464 464 + 1. Create src/<name>/ with content 465 465 + 2. Remove mono/<name>/ and commit 466 466 + 3. Re-add as subtree from src/<name>/ *) 467 467 + let create_src_actions = 468 468 + if has_subtree_hist then 469 469 + (* Subtree with history: split and push to new repo *) 470 470 + [ 471 471 + Create_directory checkouts; 472 472 + Git_subtree_split { repo = monorepo; prefix }; 473 473 + Git_init src_path; 474 474 + (* Allow pushing to checked-out branch (for monopam sync) *) 475 475 + Git_config { repo = src_path; key = "receive.denyCurrentBranch"; value = "updateInstead" }; 476 476 + Git_add_remote { repo = src_path; name = "mono"; url = Fpath.to_string monorepo }; 477 477 + Git_push_ref { repo = monorepo; target = Fpath.to_string src_path; ref_spec = "SPLIT_COMMIT:refs/heads/main" }; 478 478 + Git_checkout { repo = src_path; branch }; 479 479 + ] 480 480 + else 481 481 + (* Fresh package: copy files and create initial commit *) 482 482 + [ 483 483 + Create_directory checkouts; 484 484 + Create_directory src_path; 485 485 + Git_init src_path; 486 486 + (* Allow pushing to checked-out branch (for monopam sync) *) 487 487 + Git_config { repo = src_path; key = "receive.denyCurrentBranch"; value = "updateInstead" }; 488 488 + Git_branch_rename { repo = src_path; new_name = branch }; 489 489 + Copy_directory { src = subtree_path; dest = src_path }; 490 490 + Git_add_all src_path; 491 491 + Git_commit { repo = src_path; message = Fmt.str "Initial commit of %s" name }; 492 492 + ] 493 493 + in 494 494 + 495 495 + (* Add remote if push_url provided *) 496 496 + let remote_actions = match push_url with 497 497 + | Some url -> [ Git_add_remote { repo = src_path; name = "origin"; url } ] 498 498 + | None -> [] 499 499 + in 500 500 + 501 501 + (* Remove from mono and re-add as subtree *) 502 502 + let rejoin_actions = [ 503 503 + Git_rm { repo = monorepo; path = prefix; recursive = true }; 504 504 + Git_commit { repo = monorepo; message = Fmt.str "Remove %s for fork" name }; 505 505 + Git_subtree_add { repo = monorepo; prefix; url = Uri.of_string (Fpath.to_string src_path); branch }; 506 506 + ] in 507 507 + 508 508 + (* Update sources.toml only if push_url is a true fork (different namespace) *) 509 509 + let handle = Verse_config.handle config in 510 510 + let sources_actions = match push_url with 511 511 + | Some url when not (is_own_namespace ~handle url) -> [ 512 512 + Update_sources_toml { 513 513 + path = Fpath.(monorepo / "sources.toml"); 514 514 + name; 515 515 + entry = Sources_registry.{ 516 516 + url = normalize_git_url url; 517 517 + upstream = None; 518 518 + branch = Some branch; 519 519 + reason = None; 520 520 + origin = Some Fork; 521 521 + }; 522 522 + }; 523 523 + ] 524 524 + | Some _ -> [] (* Own namespace - no sources.toml entry needed *) 525 525 + | None -> [] 526 526 + in 527 527 + 528 528 + let actions = create_src_actions @ remote_actions @ rejoin_actions @ sources_actions in 529 529 + 530 530 + let result = { 531 531 + name; 532 532 + split_commit = if has_subtree_hist then "(will be computed)" else "(fresh package)"; 533 533 + src_path; 534 534 + push_url; 535 535 + packages_created = opam_files; 536 536 + } in 537 537 + 538 538 + Ok { discovery; actions; result; dry_run } 539 539 + end 540 540 + 541 541 + (** Build a join plan - handles both URL and local path *) 542 542 + let plan_join ~proc ~fs ~config ~source ?name ?upstream ?(dry_run = false) () = 543 543 + let is_local = is_local_path source in 544 544 + let name = match name with Some n -> n | None -> name_from_url source in 545 545 + let monorepo = Verse_config.mono_path config in 546 546 + let checkouts = Verse_config.src_path config in 547 547 + let prefix = name in 548 548 + let src_path = Fpath.(checkouts / name) in 549 549 + 550 550 + (* Gather discovery information *) 551 551 + let subtree_exists = Git.Subtree.exists ~fs ~repo:monorepo ~prefix in 552 552 + let src_exists = is_directory ~fs src_path in 553 553 + let local_is_repo = 554 554 + if is_local then begin 555 555 + match Fpath.of_string source with 556 556 + | Ok path -> Some (Git.is_repo ~proc ~fs path) 557 557 + | Error _ -> Some false 558 558 + end else None 559 559 + in 560 560 + 561 561 + let discovery = { 562 562 + mono_exists = subtree_exists; 563 563 + src_exists; 564 564 + has_subtree_history = false; 565 565 + remote_accessible = None; 566 566 + opam_files = []; (* Will be discovered after join *) 567 567 + local_path_is_repo = local_is_repo; 568 568 + } in 569 569 + 570 570 + (* Validation *) 571 571 + if subtree_exists then 572 572 + Error (Subtree_already_exists name) 573 573 + else begin 574 574 + let branch = Verse_config.default_branch in 575 575 + let actions = 576 576 + if is_local then begin 577 577 + (* Join from local directory *) 578 578 + match Fpath.of_string source with 579 579 + | Error (`Msg msg) -> raise (Invalid_argument msg) 580 580 + | Ok local_path -> 581 581 + let has_repo = Option.value ~default:false local_is_repo in 582 582 + if has_repo then 583 583 + (* Local git repo - use it directly *) 584 584 + [ 585 585 + Create_directory checkouts; 586 586 + Copy_directory { src = local_path; dest = src_path }; 587 587 + Git_subtree_add { repo = monorepo; prefix; url = Uri.of_string (Fpath.to_string src_path); branch }; 588 588 + ] 589 589 + else 590 590 + (* Local directory without git - init and commit first *) 591 591 + [ 592 592 + Create_directory checkouts; 593 593 + Create_directory src_path; 594 594 + Git_init src_path; 595 595 + Copy_directory { src = local_path; dest = src_path }; 596 596 + Git_add_all src_path; 597 597 + Git_commit { repo = src_path; message = Fmt.str "Initial commit of %s" name }; 598 598 + Git_branch_rename { repo = src_path; new_name = branch }; (* Ensure branch is named correctly *) 599 599 + Git_subtree_add { repo = monorepo; prefix; url = Uri.of_string (Fpath.to_string src_path); branch }; 600 600 + ] 601 601 + end else begin 602 602 + (* Join from URL (existing behavior) *) 603 603 + let url_uri = Uri.of_string source in 604 604 + let base_actions = [ 605 605 + Create_directory checkouts; 606 606 + Git_clone { url = source; dest = src_path; branch }; 607 607 + Git_subtree_add { repo = monorepo; prefix; url = url_uri; branch }; 608 608 + ] in 609 609 + let sources_actions = match upstream with 610 610 + | Some _ -> 611 611 + [Update_sources_toml { 612 612 + path = Fpath.(monorepo / "sources.toml"); 613 613 + name; 614 614 + entry = Sources_registry.{ 615 615 + url = normalize_git_url source; 616 616 + upstream = Option.map normalize_git_url upstream; 617 617 + branch = Some branch; 618 618 + reason = None; 619 619 + origin = Some Join; 620 620 + }; 621 621 + }] 622 622 + | None -> [] 623 623 + in 624 624 + base_actions @ sources_actions 625 625 + end 626 626 + in 627 627 + 628 628 + (* Peek at opam files if local *) 629 629 + let opam_preview = 630 630 + if is_local then 631 631 + match Fpath.of_string source with 632 632 + | Ok path -> find_opam_files ~fs path 633 633 + | Error _ -> [] 634 634 + else [] 635 635 + in 636 636 + 637 637 + let result = { 638 638 + name; 639 639 + source_url = source; 640 640 + upstream_url = upstream; 641 641 + packages_added = opam_preview; 642 642 + from_handle = None; 643 643 + } in 644 644 + 645 645 + Ok { discovery = { discovery with opam_files = opam_preview }; actions; result; dry_run } 646 646 + end 647 647 + 648 648 + (** Build a rejoin plan - add existing src/<name> back into mono/<name> *) 649 649 + let plan_rejoin ~proc ~fs ~config ~name ?(dry_run = false) () = 650 650 + let monorepo = Verse_config.mono_path config in 651 651 + let checkouts = Verse_config.src_path config in 652 652 + let prefix = name in 653 653 + let src_path = Fpath.(checkouts / name) in 654 654 + 655 655 + (* Gather discovery information *) 656 656 + let subtree_exists = Git.Subtree.exists ~fs ~repo:monorepo ~prefix in 657 657 + let src_exists = is_directory ~fs src_path in 658 658 + let src_is_repo = if src_exists then Git.is_repo ~proc ~fs src_path else false in 659 659 + let opam_files = if src_exists then find_opam_files ~fs src_path else [] in 660 660 + 661 661 + let discovery = { 662 662 + mono_exists = subtree_exists; 663 663 + src_exists; 664 664 + has_subtree_history = false; 665 665 + remote_accessible = None; 666 666 + opam_files; 667 667 + local_path_is_repo = Some src_is_repo; 668 668 + } in 669 669 + 670 670 + (* Validation *) 671 671 + if subtree_exists then 672 672 + Error (Subtree_already_exists name) 673 673 + else if not src_exists then 674 674 + Error (Src_not_found name) 675 675 + else if not src_is_repo then 676 676 + Error (Config_error (Fmt.str "src/%s exists but is not a git repository" name)) 677 677 + else begin 678 678 + let branch = Verse_config.default_branch in 679 679 + let actions = [ 680 680 + Git_subtree_add { repo = monorepo; prefix; url = Uri.of_string (Fpath.to_string src_path); branch }; 681 681 + ] in 682 682 + 683 683 + let result = { 684 684 + name; 685 685 + source_url = Fpath.to_string src_path; 686 686 + upstream_url = None; 687 687 + packages_added = opam_files; 688 688 + from_handle = None; 689 689 + } in 690 690 + 691 691 + Ok { discovery; actions; result; dry_run } 692 692 + end 693 693 + 694 694 + (** {1 Plan Execution} *) 695 695 + 696 696 + (** State tracked during plan execution *) 697 697 + type exec_state = { 698 698 + mutable split_commit: string option; 699 699 + } 700 700 + 701 701 + (** Execute a single action *) 702 702 + let execute_action ~proc ~fs ~state action = 703 703 + match action with 704 704 + | Check_remote_exists _url -> 705 705 + (* Informational only - always succeeds *) 706 706 + Ok () 707 707 + | Create_directory path -> 708 708 + ensure_dir ~fs path; 709 709 + Ok () 710 710 + | Git_init path -> 711 711 + Git.init ~proc ~fs path |> Result.map_error (fun e -> Git_error e) 712 712 + | Git_config { repo; key; value } -> 713 713 + Git.config ~proc ~fs ~key ~value repo |> Result.map_error (fun e -> Git_error e) 714 714 + | Git_clone { url; dest; branch } -> 715 715 + Git.clone ~proc ~fs ~url:(Uri.of_string url) ~branch dest 716 716 + |> Result.map_error (fun e -> Git_error e) 717 717 + | Git_subtree_split { repo; prefix } -> 718 718 + Git.Subtree.split ~proc ~fs ~repo ~prefix () 719 719 + |> Result.map (fun commit -> state.split_commit <- Some commit) 720 720 + |> Result.map_error (fun e -> Git_error e) 721 721 + | Git_subtree_add { repo; prefix; url; branch } -> 722 722 + Git.Subtree.add ~proc ~fs ~repo ~prefix ~url ~branch () 723 723 + |> Result.map_error (fun e -> Git_error e) 724 724 + | Git_add_remote { repo; name; url } -> 725 725 + Git.add_remote ~proc ~fs ~name ~url repo 726 726 + |> Result.map_error (fun e -> Git_error e) 727 727 + | Git_push_ref { repo; target; ref_spec } -> 728 728 + (* Replace SPLIT_COMMIT placeholder with actual commit if available *) 729 729 + let ref_spec = 730 730 + match state.split_commit with 731 731 + | Some commit -> String.concat "" (String.split_on_char 'S' (String.concat commit (String.split_on_char 'S' ref_spec))) 732 732 + |> fun s -> if String.starts_with ~prefix:"PLIT_COMMIT" s then 733 733 + Option.value ~default:ref_spec state.split_commit ^ String.sub s 11 (String.length s - 11) 734 734 + else s 735 735 + | None -> ref_spec 736 736 + in 737 737 + (* Better replacement: look for SPLIT_COMMIT literal *) 738 738 + let ref_spec = 739 739 + match state.split_commit with 740 740 + | Some commit -> 741 741 + if String.length ref_spec >= 12 && String.sub ref_spec 0 12 = "SPLIT_COMMIT" then 742 742 + commit ^ String.sub ref_spec 12 (String.length ref_spec - 12) 743 743 + else ref_spec 744 744 + | None -> ref_spec 745 745 + in 746 746 + Git.push_ref ~proc ~fs ~repo ~target ~ref_spec () 747 747 + |> Result.map_error (fun e -> Git_error e) 748 748 + | Git_checkout { repo; branch } -> 749 749 + Git.checkout ~proc ~fs ~branch repo 750 750 + |> Result.map_error (fun e -> Git_error e) 751 751 + | Git_branch_rename { repo; new_name } -> 752 752 + Git.branch_rename ~proc ~fs ~new_name repo 753 753 + |> Result.map_error (fun e -> Git_error e) 754 754 + | Copy_directory { src; dest } -> 755 755 + copy_directory ~fs ~src ~dest; 756 756 + Ok () 757 757 + | Git_add_all path -> 758 758 + Git.add_all ~proc ~fs path 759 759 + |> Result.map_error (fun e -> Git_error e) 760 760 + | Git_commit { repo; message } -> 761 761 + Git.commit ~proc ~fs ~message repo 762 762 + |> Result.map_error (fun e -> Git_error e) 763 763 + | Git_rm { repo; path; recursive } -> 764 764 + Git.rm ~proc ~fs ~recursive repo path 765 765 + |> Result.map_error (fun e -> Git_error e) 766 766 + | Update_sources_toml { path; name; entry } -> 767 767 + let sources = 768 768 + match Sources_registry.load ~fs:(fs :> _ Eio.Path.t) path with 769 769 + | Ok s -> s 770 770 + | Error _ -> Sources_registry.empty 771 771 + in 772 772 + let sources = Sources_registry.add sources ~subtree:name entry in 773 773 + (match Sources_registry.save ~fs:(fs :> _ Eio.Path.t) path sources with 774 774 + | Ok () -> Ok () 775 775 + | Error msg -> Error (Config_error (Fmt.str "Failed to update sources.toml: %s" msg))) 776 776 + 777 777 + (** Execute a complete fork action plan *) 778 778 + let execute_fork_plan ~proc ~fs plan = 779 779 + if plan.dry_run then 780 780 + Ok plan.result 781 781 + else begin 782 782 + let state = { split_commit = None } in 783 783 + let rec run_actions = function 784 784 + | [] -> Ok () 785 785 + | action :: rest -> 786 786 + match execute_action ~proc ~fs ~state action with 787 787 + | Error e -> Error e 788 788 + | Ok () -> run_actions rest 789 789 + in 790 790 + match run_actions plan.actions with 791 791 + | Error e -> Error e 792 792 + | Ok () -> 793 793 + (* Update result with actual split commit if available *) 794 794 + let result : fork_result = 795 795 + match state.split_commit with 796 796 + | Some commit -> { plan.result with split_commit = commit } 797 797 + | None -> plan.result 798 798 + in 799 799 + Ok result 800 800 + end 801 801 + 802 802 + (** Execute a complete join action plan *) 803 803 + let execute_join_plan ~proc ~fs plan = 804 804 + if plan.dry_run then 805 805 + Ok plan.result 806 806 + else begin 807 807 + let state = { split_commit = None } in 808 808 + let rec run_actions = function 809 809 + | [] -> Ok () 810 810 + | action :: rest -> 811 811 + match execute_action ~proc ~fs ~state action with 812 812 + | Error e -> Error e 813 813 + | Ok () -> run_actions rest 814 814 + in 815 815 + match run_actions plan.actions with 816 816 + | Error e -> Error e 817 817 + | Ok () -> Ok plan.result 818 818 + end 819 819 + 820 820 + (** {1 Legacy API (using plans internally)} *) 821 821 + 822 822 + let fork ~proc ~fs ~config ~name ?push_url ?(dry_run = false) () = 823 823 + let monorepo = Verse_config.mono_path config in 824 824 + let checkouts = Verse_config.src_path config in 825 825 + let prefix = name in 826 826 + let subtree_path = Fpath.(monorepo / prefix) in 827 827 + let src_path = Fpath.(checkouts / name) in 828 828 + (* Validate: mono/<name>/ must exist *) 829 829 + if not (Git.Subtree.exists ~fs ~repo:monorepo ~prefix) then 830 830 + Error (Subtree_not_found name) 831 831 + (* Validate: src/<name>/ must not exist *) 832 832 + else if is_directory ~fs src_path then 833 833 + Error (Src_already_exists name) 834 834 + else begin 835 835 + (* Find .opam files in subtree *) 836 836 + let packages = find_opam_files ~fs subtree_path in 837 837 + if packages = [] then 838 838 + Error (No_opam_files name) 839 839 + else if dry_run then 840 840 + Ok { name; split_commit = "(dry-run)"; src_path; push_url; packages_created = packages } 841 841 + else begin 842 842 + (* Split the subtree to get history *) 843 843 + match Git.Subtree.split ~proc ~fs ~repo:monorepo ~prefix () with 844 844 + | Error e -> Error (Git_error e) 845 845 + | Ok split_commit -> 846 846 + (* Ensure src/ exists *) 847 847 + ensure_dir ~fs checkouts; 848 848 + (* Initialize new git repo at src/<name>/ *) 849 849 + match Git.init ~proc ~fs src_path with 850 850 + | Error e -> Error (Git_error e) 851 851 + | Ok () -> 852 852 + (* Add 'origin' remote pointing to monorepo path temporarily *) 853 853 + let mono_str = Fpath.to_string monorepo in 854 854 + (match Git.add_remote ~proc ~fs ~name:"mono" ~url:mono_str src_path with 855 855 + | Error e -> Error (Git_error e) 856 856 + | Ok () -> 857 857 + (* Push split commit to local repo *) 858 858 + let ref_spec = split_commit ^ ":refs/heads/main" in 859 859 + match Git.push_ref ~proc ~fs ~repo:monorepo ~target:(Fpath.to_string src_path) ~ref_spec () with 860 860 + | Error e -> Error (Git_error e) 861 861 + | Ok () -> 862 862 + (* Checkout main branch *) 863 863 + (match Git.checkout ~proc ~fs ~branch:"main" src_path with 864 864 + | Error e -> Error (Git_error e) 865 865 + | Ok () -> 866 866 + (* Set push URL if provided *) 867 867 + let push_result = 868 868 + match push_url with 869 869 + | Some url -> 870 870 + (match Git.add_remote ~proc ~fs ~name:"origin" ~url src_path with 871 871 + | Error e -> Error (Git_error e) 872 872 + | Ok () -> Ok ()) 873 873 + | None -> Ok () 874 874 + in 875 875 + match push_result with 876 876 + | Error _ as e -> e 877 877 + | Ok () -> 878 878 + (* Only update sources.toml if there's a push URL *) 879 879 + (match push_url with 880 880 + | Some url -> 881 881 + let sources_path = Fpath.(monorepo / "sources.toml") in 882 882 + let sources = 883 883 + match Sources_registry.load ~fs:(fs :> _ Eio.Path.t) sources_path with 884 884 + | Ok s -> s 885 885 + | Error _ -> Sources_registry.empty 886 886 + in 887 887 + let entry = Sources_registry.{ 888 888 + url = normalize_git_url url; 889 889 + upstream = None; 890 890 + branch = Some "main"; 891 891 + reason = None; 892 892 + origin = Some Fork; 893 893 + } in 894 894 + let sources = Sources_registry.add sources ~subtree:name entry in 895 895 + (match Sources_registry.save ~fs:(fs :> _ Eio.Path.t) sources_path sources with 896 896 + | Ok () -> () 897 897 + | Error msg -> Logs.warn (fun m -> m "Failed to update sources.toml: %s" msg)) 898 898 + | None -> ()); 899 899 + Ok { name; split_commit; src_path; push_url; packages_created = packages })) 900 900 + end 901 901 + end 902 902 + 903 903 + let join ~proc ~fs ~config ~url ?name ?upstream ?(dry_run = false) () = 904 904 + let name = match name with Some n -> n | None -> name_from_url url in 905 905 + let monorepo = Verse_config.mono_path config in 906 906 + let checkouts = Verse_config.src_path config in 907 907 + let prefix = name in 908 908 + let subtree_path = Fpath.(monorepo / prefix) in 909 909 + let src_path = Fpath.(checkouts / name) in 910 910 + (* Validate: mono/<name>/ must not exist *) 911 911 + if Git.Subtree.exists ~fs ~repo:monorepo ~prefix then 912 912 + Error (Subtree_already_exists name) 913 913 + else if dry_run then 914 914 + Ok { name; source_url = url; upstream_url = upstream; packages_added = []; from_handle = None } 915 915 + else begin 916 916 + (* Ensure src/ exists *) 917 917 + ensure_dir ~fs checkouts; 918 918 + (* Clone to src/<name>/ *) 919 919 + let branch = Verse_config.default_branch in 920 920 + let uri = Uri.of_string url in 921 921 + match Git.clone ~proc ~fs ~url:uri ~branch src_path with 922 922 + | Error e -> Error (Git_error e) 923 923 + | Ok () -> 924 924 + (* Add subtree to monorepo *) 925 925 + match Git.Subtree.add ~proc ~fs ~repo:monorepo ~prefix ~url:uri ~branch () with 926 926 + | Error e -> Error (Git_error e) 927 927 + | Ok () -> 928 928 + (* Find .opam files in the new subtree *) 929 929 + let packages = find_opam_files ~fs subtree_path in 930 930 + (* Only update sources.toml if there's an upstream to track *) 931 931 + (match upstream with 932 932 + | Some _ -> 933 933 + let sources_path = Fpath.(monorepo / "sources.toml") in 934 934 + let sources = 935 935 + match Sources_registry.load ~fs:(fs :> _ Eio.Path.t) sources_path with 936 936 + | Ok s -> s 937 937 + | Error _ -> Sources_registry.empty 938 938 + in 939 939 + let entry = Sources_registry.{ 940 940 + url = normalize_git_url url; 941 941 + upstream = Option.map normalize_git_url upstream; 942 942 + branch = Some branch; 943 943 + reason = None; 944 944 + origin = Some Join; 945 945 + } in 946 946 + let sources = Sources_registry.add sources ~subtree:name entry in 947 947 + (match Sources_registry.save ~fs:(fs :> _ Eio.Path.t) sources_path sources with 948 948 + | Ok () -> () 949 949 + | Error msg -> Logs.warn (fun m -> m "Failed to update sources.toml: %s" msg)) 950 950 + | None -> ()); 951 951 + Ok { name; source_url = url; upstream_url = upstream; packages_added = packages; from_handle = None } 952 952 + end 953 953 + 954 954 + let join_from_verse ~proc ~fs ~config ~verse_config ~package ~handle ~fork_url ?(dry_run = false) () = 955 955 + (* First use verse fork to set up the opam entries *) 956 956 + match Verse.fork ~proc ~fs ~config:verse_config ~handle ~package ~fork_url ~dry_run () with 957 957 + | Error e -> Error (Verse_error e) 958 958 + | Ok fork_result -> 959 959 + if dry_run then 960 960 + Ok { 961 961 + name = fork_result.subtree_name; 962 962 + source_url = fork_url; 963 963 + upstream_url = Some fork_result.upstream_url; 964 964 + packages_added = fork_result.packages_forked; 965 965 + from_handle = Some handle; 966 966 + } 967 967 + else begin 968 968 + (* Now join the repository *) 969 969 + let name = fork_result.subtree_name in 970 970 + match join ~proc ~fs ~config ~url:fork_url ~name ~upstream:fork_result.upstream_url ~dry_run () with 971 971 + | Error e -> Error e 972 972 + | Ok join_result -> 973 973 + Ok { join_result with 974 974 + packages_added = fork_result.packages_forked; 975 975 + from_handle = Some handle; 976 976 + } 977 977 + end

+295

lib/fork_join.mli

reviewed

··· 1 1 + (** Fork and join operations for managing monorepo sources. 2 2 + 3 3 + This module provides operations to: 4 4 + - Fork: Split a monorepo subtree into its own repository in src/ 5 5 + - Join: Bring an external repository into the monorepo as a subtree 6 6 + 7 7 + Both operations update sources.toml to track the origin of each source. 8 8 + 9 9 + The module supports an action-based workflow where commands: 10 10 + 1. Analyze current state 11 11 + 2. Build a list of actions with reasoning 12 12 + 3. Display the plan with discovery details 13 13 + 4. Prompt for confirmation (or skip with [--yes]) 14 14 + 5. Execute actions sequentially *) 15 15 + 16 16 + (** {1 Error Types} *) 17 17 + 18 18 + type error = 19 19 + | Config_error of string (** Configuration error *) 20 20 + | Git_error of Git.error (** Git operation failed *) 21 21 + | Subtree_not_found of string (** Subtree not found in monorepo *) 22 22 + | Src_already_exists of string (** Source checkout already exists *) 23 23 + | Src_not_found of string (** Source checkout not found *) 24 24 + | Subtree_already_exists of string (** Subtree already exists in monorepo *) 25 25 + | No_opam_files of string (** No .opam files found in subtree *) 26 26 + | Verse_error of Verse.error (** Error from verse operations *) 27 27 + | User_cancelled (** User declined to proceed *) 28 28 + 29 29 + val pp_error : error Fmt.t 30 30 + (** [pp_error] formats errors. *) 31 31 + 32 32 + val pp_error_with_hint : error Fmt.t 33 33 + (** [pp_error_with_hint] formats errors with helpful hints. *) 34 34 + 35 35 + val error_hint : error -> string option 36 36 + (** [error_hint e] returns a hint string for the given error, if available. *) 37 37 + 38 38 + (** {1 Action Types} *) 39 39 + 40 40 + (** An action to be performed during fork/join *) 41 41 + type action = 42 42 + | Check_remote_exists of string (** URL - informational check *) 43 43 + | Create_directory of Fpath.t 44 44 + | Git_init of Fpath.t 45 45 + | Git_config of { repo: Fpath.t; key: string; value: string } (** Set git config *) 46 46 + | Git_clone of { url: string; dest: Fpath.t; branch: string } 47 47 + | Git_subtree_split of { repo: Fpath.t; prefix: string } 48 48 + | Git_subtree_add of { repo: Fpath.t; prefix: string; url: Uri.t; branch: string } 49 49 + | Git_add_remote of { repo: Fpath.t; name: string; url: string } 50 50 + | Git_push_ref of { repo: Fpath.t; target: string; ref_spec: string } 51 51 + | Git_checkout of { repo: Fpath.t; branch: string } 52 52 + | Git_branch_rename of { repo: Fpath.t; new_name: string } (** Rename current branch *) 53 53 + | Copy_directory of { src: Fpath.t; dest: Fpath.t } 54 54 + | Git_add_all of Fpath.t 55 55 + | Git_commit of { repo: Fpath.t; message: string } 56 56 + | Git_rm of { repo: Fpath.t; path: string; recursive: bool } (** Remove from git *) 57 57 + | Update_sources_toml of { path: Fpath.t; name: string; entry: Sources_registry.entry } 58 58 + 59 59 + (** Discovery information gathered during planning *) 60 60 + type discovery = { 61 61 + mono_exists: bool; (** Does mono/<name>/ exist? *) 62 62 + src_exists: bool; (** Does src/<name>/ exist? *) 63 63 + has_subtree_history: bool; (** Can we git subtree split? *) 64 64 + remote_accessible: bool option; (** None = not checked, Some = result *) 65 65 + opam_files: string list; (** Package names found from .opam files *) 66 66 + local_path_is_repo: bool option; (** For join from local dir *) 67 67 + } 68 68 + 69 69 + (** A complete action plan *) 70 70 + type 'a action_plan = { 71 71 + discovery: discovery; 72 72 + actions: action list; 73 73 + result: 'a; (** What we'll return on success *) 74 74 + dry_run: bool; 75 75 + } 76 76 + 77 77 + val pp_action : action Fmt.t 78 78 + (** [pp_action] formats a single action. *) 79 79 + 80 80 + val pp_discovery : discovery Fmt.t 81 81 + (** [pp_discovery] formats discovery information. *) 82 82 + 83 83 + val pp_action_plan : 'a Fmt.t -> 'a action_plan Fmt.t 84 84 + (** [pp_action_plan pp_result] formats a complete action plan. *) 85 85 + 86 86 + (** {1 Detection Functions} *) 87 87 + 88 88 + val is_local_path : string -> bool 89 89 + (** [is_local_path s] returns true if [s] looks like a local filesystem path 90 90 + rather than a URL. *) 91 91 + 92 92 + val suggest_push_url : fs:Eio.Fs.dir_ty Eio.Path.t -> ?knot:string -> Fpath.t -> string option 93 93 + (** [suggest_push_url ~fs ?knot subtree_path] tries to derive a push URL from the 94 94 + dune-project file in the subtree. Returns [Some url] if a source URL can 95 95 + be found and converted to SSH push format, [None] otherwise. 96 96 + 97 97 + @param knot Optional git push server for tangled URLs (default: git.recoil.org) *) 98 98 + 99 99 + (** {1 Result Types} *) 100 100 + 101 101 + (** Result of a fork operation. *) 102 102 + type fork_result = { 103 103 + name : string; (** Subtree/repository name *) 104 104 + split_commit : string; (** Git commit SHA from subtree split *) 105 105 + src_path : Fpath.t; (** Path to the new source checkout *) 106 106 + push_url : string option; (** Remote push URL if provided *) 107 107 + packages_created : string list; (** Package names from .opam files *) 108 108 + } 109 109 + 110 110 + val pp_fork_result : fork_result Fmt.t 111 111 + (** [pp_fork_result] formats a fork result. *) 112 112 + 113 113 + (** Result of a join operation. *) 114 114 + type join_result = { 115 115 + name : string; (** Subtree/repository name *) 116 116 + source_url : string; (** URL the repository was cloned from *) 117 117 + upstream_url : string option; (** Original upstream if this is a fork *) 118 118 + packages_added : string list; (** Package names from .opam files *) 119 119 + from_handle : string option; (** Verse handle if joined from verse *) 120 120 + } 121 121 + 122 122 + val pp_join_result : join_result Fmt.t 123 123 + (** [pp_join_result] formats a join result. *) 124 124 + 125 125 + (** {1 Plan Builders} *) 126 126 + 127 127 + val plan_fork : 128 128 + proc:_ Eio.Process.mgr -> 129 129 + fs:Eio.Fs.dir_ty Eio.Path.t -> 130 130 + config:Verse_config.t -> 131 131 + name:string -> 132 132 + ?push_url:string -> 133 133 + ?dry_run:bool -> 134 134 + unit -> 135 135 + (fork_result action_plan, error) result 136 136 + (** [plan_fork ~proc ~fs ~config ~name ?push_url ?dry_run ()] builds a fork plan. 137 137 + 138 138 + This analyzes the current state and builds a list of actions to: 139 139 + - For subtrees with history: split subtree, create repo, push history 140 140 + - For fresh packages: create repo, copy files, initial commit 141 141 + 142 142 + The plan can be displayed to the user and executed with [execute_fork_plan]. 143 143 + 144 144 + @param name Name of the subtree to fork (directory name under mono/) 145 145 + @param push_url Optional remote URL to add as origin for pushing 146 146 + @param dry_run If true, mark plan as dry-run (execute will skip actions) *) 147 147 + 148 148 + val plan_join : 149 149 + proc:_ Eio.Process.mgr -> 150 150 + fs:Eio.Fs.dir_ty Eio.Path.t -> 151 151 + config:Verse_config.t -> 152 152 + source:string -> 153 153 + ?name:string -> 154 154 + ?upstream:string -> 155 155 + ?dry_run:bool -> 156 156 + unit -> 157 157 + (join_result action_plan, error) result 158 158 + (** [plan_join ~proc ~fs ~config ~source ?name ?upstream ?dry_run ()] builds a join plan. 159 159 + 160 160 + This analyzes the source (URL or local path) and builds a list of actions to: 161 161 + - For URLs: clone repo, add subtree 162 162 + - For local directories: copy/init repo, add subtree 163 163 + 164 164 + The plan can be displayed to the user and executed with [execute_join_plan]. 165 165 + 166 166 + @param source Git URL or local filesystem path to join 167 167 + @param name Override the subtree directory name (default: derived from source) 168 168 + @param upstream Original upstream URL if this is your fork 169 169 + @param dry_run If true, mark plan as dry-run (execute will skip actions) *) 170 170 + 171 171 + val plan_rejoin : 172 172 + proc:_ Eio.Process.mgr -> 173 173 + fs:Eio.Fs.dir_ty Eio.Path.t -> 174 174 + config:Verse_config.t -> 175 175 + name:string -> 176 176 + ?dry_run:bool -> 177 177 + unit -> 178 178 + (join_result action_plan, error) result 179 179 + (** [plan_rejoin ~proc ~fs ~config ~name ?dry_run ()] builds a rejoin plan. 180 180 + 181 181 + This is used to add an existing src/<name>/ repository back into mono/<name>/ 182 182 + as a subtree. Useful after forking a package and removing it from the monorepo. 183 183 + 184 184 + Requires: 185 185 + - src/<name>/ must exist and be a git repository 186 186 + - mono/<name>/ must not exist 187 187 + 188 188 + The plan can be displayed to the user and executed with [execute_join_plan]. 189 189 + 190 190 + @param name Name of the subtree (directory name under src/ and mono/) 191 191 + @param dry_run If true, mark plan as dry-run (execute will skip actions) *) 192 192 + 193 193 + (** {1 Plan Execution} *) 194 194 + 195 195 + val execute_fork_plan : 196 196 + proc:_ Eio.Process.mgr -> 197 197 + fs:Eio.Fs.dir_ty Eio.Path.t -> 198 198 + fork_result action_plan -> 199 199 + (fork_result, error) result 200 200 + (** [execute_fork_plan ~proc ~fs plan] executes a fork action plan. 201 201 + 202 202 + Returns the fork result with the actual split commit (if applicable). 203 203 + If the plan is marked as dry-run, returns the plan's result without 204 204 + executing any actions. *) 205 205 + 206 206 + val execute_join_plan : 207 207 + proc:_ Eio.Process.mgr -> 208 208 + fs:Eio.Fs.dir_ty Eio.Path.t -> 209 209 + join_result action_plan -> 210 210 + (join_result, error) result 211 211 + (** [execute_join_plan ~proc ~fs plan] executes a join action plan. 212 212 + 213 213 + If the plan is marked as dry-run, returns the plan's result without 214 214 + executing any actions. *) 215 215 + 216 216 + (** {1 Fork Operations} *) 217 217 + 218 218 + val fork : 219 219 + proc:_ Eio.Process.mgr -> 220 220 + fs:Eio.Fs.dir_ty Eio.Path.t -> 221 221 + config:Verse_config.t -> 222 222 + name:string -> 223 223 + ?push_url:string -> 224 224 + ?dry_run:bool -> 225 225 + unit -> 226 226 + (fork_result, error) result 227 227 + (** [fork ~proc ~fs ~config ~name ?push_url ?dry_run ()] splits a monorepo 228 228 + subtree into its own repository. 229 229 + 230 230 + This operation: 231 231 + 1. Validates mono/<name>/ exists 232 232 + 2. Validates src/<name>/ does not exist 233 233 + 3. Uses [git subtree split] to extract history 234 234 + 4. Creates a new git repo at src/<name>/ 235 235 + 5. Pushes the split commit to the new repo 236 236 + 6. Updates sources.toml with [origin = "fork"] 237 237 + 7. Auto-discovers packages from .opam files 238 238 + 239 239 + @param name Name of the subtree to fork (directory name under mono/) 240 240 + @param push_url Optional remote URL to add as origin for pushing 241 241 + @param dry_run If true, validate and report what would be done *) 242 242 + 243 243 + (** {1 Join Operations} *) 244 244 + 245 245 + val join : 246 246 + proc:_ Eio.Process.mgr -> 247 247 + fs:Eio.Fs.dir_ty Eio.Path.t -> 248 248 + config:Verse_config.t -> 249 249 + url:string -> 250 250 + ?name:string -> 251 251 + ?upstream:string -> 252 252 + ?dry_run:bool -> 253 253 + unit -> 254 254 + (join_result, error) result 255 255 + (** [join ~proc ~fs ~config ~url ?name ?upstream ?dry_run ()] brings an external 256 256 + repository into the monorepo. 257 257 + 258 258 + This operation: 259 259 + 1. Derives name from URL if not provided 260 260 + 2. Validates mono/<name>/ does not exist 261 261 + 3. Clones the repository to src/<name>/ 262 262 + 4. Uses [git subtree add] to bring into monorepo 263 263 + 5. Updates sources.toml with [origin = "join"] 264 264 + 6. Auto-discovers packages from .opam files 265 265 + 266 266 + @param url Git URL to clone from 267 267 + @param name Override the subtree directory name (default: derived from URL) 268 268 + @param upstream Original upstream URL if this is your fork of another project 269 269 + @param dry_run If true, validate and report what would be done *) 270 270 + 271 271 + val join_from_verse : 272 272 + proc:_ Eio.Process.mgr -> 273 273 + fs:Eio.Fs.dir_ty Eio.Path.t -> 274 274 + config:Verse_config.t -> 275 275 + verse_config:Verse_config.t -> 276 276 + package:string -> 277 277 + handle:string -> 278 278 + fork_url:string -> 279 279 + ?dry_run:bool -> 280 280 + unit -> 281 281 + (join_result, error) result 282 282 + (** [join_from_verse ~proc ~fs ~config ~verse_config ~package ~handle ~fork_url 283 283 + ?dry_run ()] joins a package from a verse member's repository. 284 284 + 285 285 + This combines [Verse.fork] (to set up opam entries) with [join]: 286 286 + 1. Looks up the package in verse/<handle>-opam/ 287 287 + 2. Finds all packages sharing the same git repository 288 288 + 3. Creates opam entries pointing to your fork 289 289 + 4. Clones and adds the subtree 290 290 + 291 291 + @param verse_config Verse configuration (for accessing verse/ directory) 292 292 + @param package Package name to look up 293 293 + @param handle Verse member handle (e.g., "avsm.bsky.social") 294 294 + @param fork_url Your fork URL 295 295 + @param dry_run If true, validate and report what would be done *)

+314 -162

lib/forks.ml

reviewed

··· 1 1 (** Fork graph discovery via verse opam repos. 2 2 3 3 - Scans verse opam repos to discover dev-repo URLs, adds git remotes 4 4 - to local checkouts, and computes fork relationships. *) 3 3 + Scans verse opam repos to discover dev-repo URLs, adds git remotes to local 4 4 + checkouts, and computes fork relationships. *) 5 5 6 6 let src = Logs.Src.create "monopam.forks" ~doc:"Fork analysis" 7 7 + 7 8 module Log = (val Logs.src_log src : Logs.LOG) 8 9 9 9 - (** A dev-repo source from a specific member *) 10 10 + (* ==================== Fetch Cache ==================== *) 11 11 + 12 12 + (** Default cache timeout in seconds (1 hour) *) 13 13 + let default_cache_timeout = 3600.0 14 14 + 15 15 + (** In-memory cache of last fetch times *) 16 16 + let fetch_cache : (string, float) Hashtbl.t = Hashtbl.create 64 17 17 + 18 18 + (** Cache file path - uses XDG cache directory via Verse_config *) 19 19 + let cache_file_path () = 20 20 + Fpath.(to_string (Verse_config.cache_dir () / "fetch-cache.json")) 21 21 + 22 22 + (** Load cache from disk *) 23 23 + let load_cache () = 24 24 + let path = cache_file_path () in 25 25 + if Sys.file_exists path then begin 26 26 + try 27 27 + let content = In_channel.with_open_text path In_channel.input_all in 28 28 + (* Simple JSON parsing for {"key": timestamp, ...} *) 29 29 + let content = String.trim content in 30 30 + if String.length content > 2 then begin 31 31 + let inner = String.sub content 1 (String.length content - 2) in 32 32 + let pairs = String.split_on_char ',' inner in 33 33 + List.iter (fun pair -> 34 34 + let pair = String.trim pair in 35 35 + match String.split_on_char ':' pair with 36 36 + | [key; value] -> 37 37 + let key = String.trim key in 38 38 + let value = String.trim value in 39 39 + (* Strip quotes from key *) 40 40 + let key = if String.length key > 2 && key.[0] = '"' then 41 41 + String.sub key 1 (String.length key - 2) 42 42 + else key 43 43 + in 44 44 + (match float_of_string_opt value with 45 45 + | Some ts -> Hashtbl.replace fetch_cache key ts 46 46 + | None -> ()) 47 47 + | _ -> ()) 48 48 + pairs 49 49 + end 50 50 + with _ -> () 51 51 + end 52 52 + 53 53 + (** Save cache to disk *) 54 54 + let save_cache () = 55 55 + let path = cache_file_path () in 56 56 + try 57 57 + (* Create directory if needed *) 58 58 + let dir = Filename.dirname path in 59 59 + if not (Sys.file_exists dir) then 60 60 + ignore (Sys.command (Printf.sprintf "mkdir -p %s" (Filename.quote dir))); 61 61 + (* Write cache as JSON *) 62 62 + Out_channel.with_open_text path (fun oc -> 63 63 + output_string oc "{\n"; 64 64 + let first = ref true in 65 65 + Hashtbl.iter (fun key ts -> 66 66 + if not !first then output_string oc ",\n"; 67 67 + first := false; 68 68 + Printf.fprintf oc " \"%s\": %.0f" key ts) 69 69 + fetch_cache; 70 70 + output_string oc "\n}\n") 71 71 + with _ -> () 72 72 + 73 73 + (** Check if a fetch is needed for a cache key *) 74 74 + let needs_fetch ~refresh ~timeout key = 75 75 + if refresh then true 76 76 + else begin 77 77 + (* Load cache on first access *) 78 78 + if Hashtbl.length fetch_cache = 0 then load_cache (); 79 79 + match Hashtbl.find_opt fetch_cache key with 80 80 + | None -> true 81 81 + | Some last_fetch -> 82 82 + let now = Unix.gettimeofday () in 83 83 + now -. last_fetch > timeout 84 84 + end 85 85 + 86 86 + (** Record a successful fetch *) 87 87 + let record_fetch key = 88 88 + let now = Unix.gettimeofday () in 89 89 + Hashtbl.replace fetch_cache key now; 90 90 + save_cache () 91 91 + 10 92 type repo_source = { 11 11 - handle : string; (** Member handle or "me" *) 12 12 - url : Uri.t; (** Normalized git URL *) 13 13 - packages : string list; (** Opam packages from this repo *) 93 93 + handle : string; (** Member handle or "me" *) 94 94 + url : Uri.t; (** Normalized git URL *) 95 95 + packages : string list; (** Opam packages from this repo *) 14 96 } 97 97 + (** A dev-repo source from a specific member *) 15 98 16 99 (** Fork relationship between two sources *) 17 100 type relationship = 18 18 - | Same_url (** Same git URL *) 19 19 - | Same_commit (** Different URLs but same HEAD *) 20 20 - | I_am_ahead of int (** They forked from me, I'm N commits ahead *) 21 21 - | I_am_behind of int (** I forked from them, they're N commits ahead *) 101 101 + | Same_url (** Same git URL *) 102 102 + | Same_commit (** Different URLs but same HEAD *) 103 103 + | I_am_ahead of int (** They forked from me, I'm N commits ahead *) 104 104 + | I_am_behind of int (** I forked from them, they're N commits ahead *) 22 105 | Diverged of { common_ancestor : string; my_ahead : int; their_ahead : int } 23 23 - | Unrelated (** No common history *) 24 24 - | Not_fetched (** Remote not yet fetched *) 106 106 + | Unrelated (** No common history *) 107 107 + | Not_fetched (** Remote not yet fetched *) 25 108 26 26 - (** Analysis result for a single repository *) 27 109 type repo_analysis = { 28 28 - repo_name : string; (** Repository basename *) 29 29 - my_source : repo_source option; (** My dev-repo if I have it *) 110 110 + repo_name : string; (** Repository basename *) 111 111 + my_source : repo_source option; (** My dev-repo if I have it *) 30 112 verse_sources : (string * repo_source * relationship) list; 31 31 - (** (handle, source, relationship to me) *) 113 113 + (** (handle, source, relationship to me) *) 32 114 } 115 115 + (** Analysis result for a single repository *) 33 116 117 117 + type t = { repos : repo_analysis list } 34 118 (** Full fork analysis result *) 35 35 - type t = { 36 36 - repos : repo_analysis list; 37 37 - } 38 119 39 120 let pp_relationship ppf = function 40 121 | Same_url -> Fmt.string ppf "same URL" ··· 46 127 | Unrelated -> Fmt.string ppf "unrelated" 47 128 | Not_fetched -> Fmt.string ppf "not fetched" 48 129 49 49 - let pp_repo_source ppf src = 50 50 - Fmt.pf ppf "%s" (Uri.to_string src.url) 130 130 + let pp_repo_source ppf src = Fmt.pf ppf "%s" (Uri.to_string src.url) 51 131 52 132 let pp_repo_analysis ppf analysis = 53 133 Fmt.pf ppf "@[<v 2>%s:@," analysis.repo_name; ··· 81 161 | I_am_ahead n -> Fmt.(styled `Cyan (fun ppf -> pf ppf "-%d")) ppf n 82 162 | I_am_behind n -> Fmt.(styled `Red (fun ppf -> pf ppf "+%d")) ppf n 83 163 | Diverged { common_ancestor = _; my_ahead; their_ahead } -> 84 84 - Fmt.(styled `Yellow (fun ppf (a, b) -> pf ppf "+%d/-%d" a b)) ppf (their_ahead, my_ahead) 164 164 + Fmt.(styled `Yellow (fun ppf (a, b) -> pf ppf "+%d/-%d" a b)) 165 165 + ppf (their_ahead, my_ahead) 85 166 | Unrelated -> Fmt.(styled `Magenta string) ppf "?" 86 167 | Not_fetched -> Fmt.(styled `Faint string) ppf "~" 87 168 ··· 91 172 List.filter (fun (_, _, rel) -> is_actionable rel) analysis.verse_sources 92 173 in 93 174 let in_sync = 94 94 - List.for_all (fun (_, _, rel) -> 95 95 - match rel with Same_url | Same_commit -> true | _ -> false) 175 175 + List.for_all 176 176 + (fun (_, _, rel) -> 177 177 + match rel with Same_url | Same_commit -> true | _ -> false) 96 178 analysis.verse_sources 97 179 in 98 180 let all_not_fetched = 99 99 - List.for_all (fun (_, _, rel) -> 100 100 - match rel with Not_fetched -> true | _ -> false) 181 181 + List.for_all 182 182 + (fun (_, _, rel) -> match rel with Not_fetched -> true | _ -> false) 101 183 analysis.verse_sources 102 184 in 103 185 (actionable, in_sync, all_not_fetched) ··· 106 188 let abbrev_handle h = 107 189 (* Use first part before dot, max 3 chars *) 108 190 match String.split_on_char '.' h with 109 109 - | first :: _ -> if String.length first <= 4 then first else String.sub first 0 3 191 191 + | first :: _ -> 192 192 + if String.length first <= 4 then first else String.sub first 0 3 110 193 | [] -> h 111 194 112 195 (** Print a list of (handle, rel) pairs with colors *) 113 196 let pp_changes ppf actionable = 114 197 let first = ref true in 115 115 - List.iter (fun (h, _, rel) -> 116 116 - if not !first then Fmt.pf ppf " "; 117 117 - first := false; 118 118 - Fmt.pf ppf "%s%a" (abbrev_handle h) pp_rel_short rel) 198 198 + List.iter 199 199 + (fun (h, _, rel) -> 200 200 + if not !first then Fmt.pf ppf " "; 201 201 + first := false; 202 202 + Fmt.pf ppf "%s%a" (abbrev_handle h) pp_rel_short rel) 119 203 actionable 120 204 121 205 (** Succinct summary: dense one-line-per-repo format *) ··· 127 211 let in_sync = ref [] in 128 212 let not_mine = ref [] in 129 213 130 130 - List.iter (fun r -> 131 131 - let (actionable, is_in_sync, _) = summarize_repo r in 132 132 - match r.my_source with 133 133 - | None -> 134 134 - not_mine := r :: !not_mine 135 135 - | Some _ when actionable <> [] -> 136 136 - with_actions := (r, actionable) :: !with_actions 137 137 - | Some _ when is_in_sync -> 138 138 - in_sync := r :: !in_sync 139 139 - | Some _ -> 140 140 - (* Has verse sources but all same URL - treat as in sync *) 141 141 - in_sync := r :: !in_sync) 214 214 + List.iter 215 215 + (fun r -> 216 216 + let actionable, is_in_sync, _ = summarize_repo r in 217 217 + match r.my_source with 218 218 + | None -> not_mine := r :: !not_mine 219 219 + | Some _ when actionable <> [] -> 220 220 + with_actions := (r, actionable) :: !with_actions 221 221 + | Some _ when is_in_sync -> in_sync := r :: !in_sync 222 222 + | Some _ -> 223 223 + (* Has verse sources but all same URL - treat as in sync *) 224 224 + in_sync := r :: !in_sync) 142 225 t.repos; 143 226 144 227 (* Print header with counts *) ··· 146 229 let sync_count = List.length !in_sync in 147 230 let other_count = List.length !not_mine in 148 231 Fmt.pf ppf "%a %a need attention, %a synced, %a others\n" 149 149 - Fmt.(styled `Bold string) "Verse:" 150 150 - Fmt.(styled (if action_count > 0 then `Red else `Green) int) action_count 151 151 - Fmt.(styled `Green int) sync_count 152 152 - Fmt.(styled `Faint int) other_count; 232 232 + Fmt.(styled `Bold string) 233 233 + "Verse:" 234 234 + Fmt.(styled (if action_count > 0 then `Red else `Green) int) 235 235 + action_count 236 236 + Fmt.(styled `Green int) 237 237 + sync_count 238 238 + Fmt.(styled `Faint int) 239 239 + other_count; 153 240 154 241 (* Print repos needing attention - dense format *) 155 242 if !with_actions <> [] then 156 156 - List.iter (fun (r, actionable) -> 157 157 - Fmt.pf ppf " %-22s %a\n" r.repo_name pp_changes actionable) 243 243 + List.iter 244 244 + (fun (r, actionable) -> 245 245 + Fmt.pf ppf " %-22s %a\n" r.repo_name pp_changes actionable) 158 246 (List.rev !with_actions); 159 247 160 248 (* Print in-sync repos if show_all *) 161 249 if show_all && !in_sync <> [] then begin 162 162 - let in_sync_sorted = List.sort (fun a b -> String.compare a.repo_name b.repo_name) !in_sync in 163 163 - List.iter (fun r -> 164 164 - Fmt.pf ppf " %-22s %a\n" r.repo_name Fmt.(styled `Green string) "=") 250 250 + let in_sync_sorted = 251 251 + List.sort (fun a b -> String.compare a.repo_name b.repo_name) !in_sync 252 252 + in 253 253 + List.iter 254 254 + (fun r -> 255 255 + Fmt.pf ppf " %-22s %a\n" r.repo_name Fmt.(styled `Green string) "=") 165 256 in_sync_sorted 166 257 end; 167 258 ··· 169 260 if !not_mine <> [] then begin 170 261 if show_all then begin 171 262 (* List each repo with ~ *) 172 172 - let not_mine_sorted = List.sort (fun a b -> String.compare a.repo_name b.repo_name) !not_mine in 173 173 - List.iter (fun r -> 174 174 - let handles = List.map (fun (h, _, _) -> abbrev_handle h) r.verse_sources 175 175 - |> List.sort_uniq String.compare in 176 176 - Fmt.pf ppf " %-22s %a\n" r.repo_name 177 177 - Fmt.(styled `Faint (fun ppf s -> pf ppf "%s~" s)) (String.concat "," handles)) 263 263 + let not_mine_sorted = 264 264 + List.sort 265 265 + (fun a b -> String.compare a.repo_name b.repo_name) 266 266 + !not_mine 267 267 + in 268 268 + List.iter 269 269 + (fun r -> 270 270 + let handles = 271 271 + List.map (fun (h, _, _) -> abbrev_handle h) r.verse_sources 272 272 + |> List.sort_uniq String.compare 273 273 + in 274 274 + Fmt.pf ppf " %-22s %a\n" r.repo_name 275 275 + Fmt.(styled `Faint (fun ppf s -> pf ppf "%s~" s)) 276 276 + (String.concat "," handles)) 178 277 not_mine_sorted 179 179 - end else begin 278 278 + end 279 279 + else begin 180 280 (* Compact summary *) 181 281 let grouped = Hashtbl.create 16 in 182 182 - List.iter (fun r -> 183 183 - List.iter (fun (h, _, _) -> 184 184 - let existing = try Hashtbl.find grouped h with Not_found -> [] in 185 185 - Hashtbl.replace grouped h (r.repo_name :: existing)) 186 186 - r.verse_sources) 282 282 + List.iter 283 283 + (fun r -> 284 284 + List.iter 285 285 + (fun (h, _, _) -> 286 286 + let existing = 287 287 + try Hashtbl.find grouped h with Not_found -> [] 288 288 + in 289 289 + Hashtbl.replace grouped h (r.repo_name :: existing)) 290 290 + r.verse_sources) 187 291 !not_mine; 188 188 - Fmt.pf ppf " %a " Fmt.(styled (`Bold) string) "Others:"; 292 292 + Fmt.pf ppf " %a " Fmt.(styled `Bold string) "Others:"; 189 293 let first = ref true in 190 190 - Hashtbl.iter (fun h repos -> 191 191 - if not !first then Fmt.pf ppf ", "; 192 192 - first := false; 193 193 - Fmt.(styled `Faint (fun ppf (h, n) -> pf ppf "%s(%d)" h n)) ppf (abbrev_handle h, List.length repos)) 294 294 + Hashtbl.iter 295 295 + (fun h repos -> 296 296 + if not !first then Fmt.pf ppf ", "; 297 297 + first := false; 298 298 + Fmt.(styled `Faint (fun ppf (h, n) -> pf ppf "%s(%d)" h n)) 299 299 + ppf 300 300 + (abbrev_handle h, List.length repos)) 194 301 grouped; 195 302 Fmt.pf ppf "\n" 196 303 end ··· 199 306 200 307 let pp_summary ppf t = pp_summary' ~show_all:false ppf t 201 308 202 202 - (** Normalize a git URL for comparison. 203 203 - Handles: git+https, https, git@, with/without .git suffix *) 309 309 + (** Normalize a git URL for comparison. Handles: git+https, https, git@, 310 310 + with/without .git suffix *) 204 311 let normalize_url url = 205 312 let s = Uri.to_string url in 206 313 (* Strip git+ prefix *) 207 207 - let s = if String.starts_with ~prefix:"git+" s then 314 314 + let s = 315 315 + if String.starts_with ~prefix:"git+" s then 208 316 String.sub s 4 (String.length s - 4) 209 317 else s 210 318 in ··· 214 322 "https://github.com/" ^ String.sub s 15 (String.length s - 15) 215 323 else if String.starts_with ~prefix:"git@gitlab.com:" s then 216 324 "https://gitlab.com/" ^ String.sub s 15 (String.length s - 15) 217 217 - else if String.starts_with ~prefix:"git@git.recoil.org:" s then 218 218 - "https://git.recoil.org/" ^ String.sub s 19 (String.length s - 19) 325 325 + else if String.starts_with ~prefix:"git@git." s then 326 326 + (* Generic git.<domain>: pattern - convert git@git.<domain>:path to https://git.<domain>/path *) 327 327 + match String.index_opt s ':' with 328 328 + | Some colon_pos -> 329 329 + let host = String.sub s 4 (colon_pos - 4) in (* "git.<domain>" *) 330 330 + let path = String.sub s (colon_pos + 1) (String.length s - colon_pos - 1) in 331 331 + "https://" ^ host ^ "/" ^ path 332 332 + | None -> s 219 333 else s 220 334 in 221 335 (* Strip .git suffix *) 222 222 - let s = if String.ends_with ~suffix:".git" s then 336 336 + let s = 337 337 + if String.ends_with ~suffix:".git" s then 223 338 String.sub s 0 (String.length s - 4) 224 339 else s 225 340 in 226 341 (* Strip trailing slash *) 227 227 - let s = if String.ends_with ~suffix:"/" s then 228 228 - String.sub s 0 (String.length s - 1) 342 342 + let s = 343 343 + if String.ends_with ~suffix:"/" s then String.sub s 0 (String.length s - 1) 229 344 else s 230 345 in 231 346 Uri.of_string s ··· 257 372 let versions = Eio.Path.read_dir eio_pkg in 258 373 match versions with 259 374 | [] -> None 260 260 - | version :: _ -> 375 375 + | version :: _ -> ( 261 376 let opam_path = Fpath.(pkg_dir / version / "opam") in 262 377 let eio_opam = Eio.Path.(fs / Fpath.to_string opam_path) in 263 378 try 264 379 let content = Eio.Path.load eio_opam in 265 265 - let opamfile = OpamParser.FullPos.string content (Fpath.to_string opam_path) in 380 380 + let opamfile = 381 381 + OpamParser.FullPos.string content (Fpath.to_string opam_path) 382 382 + in 266 383 match Opam_repo.find_dev_repo opamfile.file_contents with 267 384 | None -> None 268 385 | Some url_str -> 269 386 if Opam_repo.is_git_url url_str then 270 387 Some (pkg_name, Opam_repo.normalize_git_url url_str) 271 388 else None 272 272 - with _ -> None 389 389 + with _ -> None) 273 390 with _ -> None) 274 391 package_names 275 392 with _ -> [] 276 393 277 277 - (** Fetch a verse opam repo *) 278 278 - let fetch_verse_opam_repo ~proc ~fs path = 279 279 - let cwd = Eio.Path.(fs / Fpath.to_string path) in 280 280 - let cmd = ["git"; "fetch"; "--quiet"] in 281 281 - Log.debug (fun m -> m "Running: %s (in %a)" (String.concat " " cmd) Fpath.pp path); 282 282 - Eio.Switch.run @@ fun sw -> 283 283 - let child = Eio.Process.spawn proc ~sw ~cwd 284 284 - ~stdout:(Eio.Flow.buffer_sink (Buffer.create 16)) 285 285 - ~stderr:(Eio.Flow.buffer_sink (Buffer.create 16)) 286 286 - cmd 287 287 - in 288 288 - match Eio.Process.await child with 289 289 - | `Exited 0 -> () 290 290 - | _ -> Log.debug (fun m -> m "Failed to fetch %a" Fpath.pp path) 394 394 + (** Fetch a verse opam repo (with caching) *) 395 395 + let fetch_verse_opam_repo ~proc ~fs ~refresh path = 396 396 + let cache_key = "verse-opam/" ^ Fpath.to_string path in 397 397 + if not (needs_fetch ~refresh ~timeout:default_cache_timeout cache_key) then begin 398 398 + Log.debug (fun m -> m "Skipping fetch for %a (cached)" Fpath.pp path); 399 399 + () 400 400 + end else begin 401 401 + let cwd = Eio.Path.(fs / Fpath.to_string path) in 402 402 + let cmd = ["git"; "fetch"; "--quiet"] in 403 403 + Log.debug (fun m -> m "Running: %s (in %a)" (String.concat " " cmd) Fpath.pp path); 404 404 + Eio.Switch.run @@ fun sw -> 405 405 + let child = Eio.Process.spawn proc ~sw ~cwd 406 406 + ~stdout:(Eio.Flow.buffer_sink (Buffer.create 16)) 407 407 + ~stderr:(Eio.Flow.buffer_sink (Buffer.create 16)) 408 408 + cmd 409 409 + in 410 410 + match Eio.Process.await child with 411 411 + | `Exited 0 -> record_fetch cache_key 412 412 + | _ -> Log.debug (fun m -> m "Failed to fetch %a" Fpath.pp path) 413 413 + end 291 414 292 415 (** Scan all verse opam repos and build a map: repo_basename -> [(handle, url, [packages])] *) 293 293 - let scan_all_verse_opam_repos ~proc ~fs ~verse_path () = 416 416 + let scan_all_verse_opam_repos ~proc ~fs ~verse_path ~refresh () = 294 417 let eio_verse = Eio.Path.(fs / Fpath.to_string verse_path) in 295 418 let entries = try Eio.Path.read_dir eio_verse with _ -> [] in 296 419 (* Find opam repo directories (ending in -opam) *) 297 420 let opam_dirs = List.filter (fun name -> String.ends_with ~suffix:"-opam" name) entries in 298 298 - (* Fetch each opam repo first *) 299 299 - Log.info (fun m -> m "Fetching %d verse opam repos" (List.length opam_dirs)); 421 421 + (* Fetch each opam repo first (respecting cache unless refresh) *) 422 422 + Log.info (fun m -> m "Checking %d verse opam repos" (List.length opam_dirs)); 300 423 List.iter (fun opam_dir -> 301 424 let opam_path = Fpath.(verse_path / opam_dir) in 302 302 - fetch_verse_opam_repo ~proc ~fs opam_path) 425 425 + fetch_verse_opam_repo ~proc ~fs ~refresh opam_path) 303 426 opam_dirs; 304 427 (* Build map: repo_basename -> [(handle, url, [packages])] *) 305 428 let repo_map = Hashtbl.create 64 in 306 429 List.iter 307 430 (fun opam_dir -> 308 308 - let handle = String.sub opam_dir 0 (String.length opam_dir - 5) in (* strip -opam *) 431 431 + let handle = String.sub opam_dir 0 (String.length opam_dir - 5) in 432 432 + (* strip -opam *) 309 433 let opam_path = Fpath.(verse_path / opam_dir) in 310 434 let pkg_urls = scan_verse_opam_repo ~fs opam_path in 311 435 (* Group by repo basename *) ··· 313 437 List.iter 314 438 (fun (pkg_name, url) -> 315 439 let repo = repo_basename url in 316 316 - let existing = try Hashtbl.find by_repo repo with Not_found -> (url, []) in 317 317 - let (existing_url, pkgs) = existing in 440 440 + let existing = 441 441 + try Hashtbl.find by_repo repo with Not_found -> (url, []) 442 442 + in 443 443 + let existing_url, pkgs = existing in 318 444 Hashtbl.replace by_repo repo (existing_url, pkg_name :: pkgs)) 319 445 pkg_urls; 320 446 (* Add to main map *) 321 447 Hashtbl.iter 322 448 (fun repo (url, pkgs) -> 323 449 let source = { handle; url; packages = pkgs } in 324 324 - let existing = try Hashtbl.find repo_map repo with Not_found -> [] in 450 450 + let existing = 451 451 + try Hashtbl.find repo_map repo with Not_found -> [] 452 452 + in 325 453 Hashtbl.replace repo_map repo (source :: existing)) 326 454 by_repo) 327 455 opam_dirs; ··· 337 465 (fun pkg -> 338 466 let repo = Package.repo_name pkg in 339 467 let url = Package.dev_repo pkg in 340 340 - let existing = try Hashtbl.find repo_map repo with Not_found -> (url, []) in 341 341 - let (_, pkgs) = existing in 468 468 + let existing = 469 469 + try Hashtbl.find repo_map repo with Not_found -> (url, []) 470 470 + in 471 471 + let _, pkgs = existing in 342 472 Hashtbl.replace repo_map repo (url, Package.name pkg :: pkgs)) 343 473 packages; 344 474 repo_map ··· 349 479 (** Check if a remote exists *) 350 480 let remote_exists ~proc ~fs ~repo remote_name = 351 481 let cwd = Eio.Path.(fs / Fpath.to_string repo) in 352 352 - let result = Eio.Switch.run @@ fun sw -> 482 482 + let result = 483 483 + Eio.Switch.run @@ fun sw -> 353 484 let buf = Buffer.create 256 in 354 354 - let child = Eio.Process.spawn proc ~sw ~cwd 355 355 - ~stdout:(Eio.Flow.buffer_sink buf) 485 485 + let child = 486 486 + Eio.Process.spawn proc ~sw ~cwd ~stdout:(Eio.Flow.buffer_sink buf) 356 487 ~stderr:(Eio.Flow.buffer_sink (Buffer.create 16)) 357 357 - ["git"; "remote"; "get-url"; remote_name] 488 488 + [ "git"; "remote"; "get-url"; remote_name ] 358 489 in 359 359 - match Eio.Process.await child with 360 360 - | `Exited 0 -> true 361 361 - | _ -> false 490 490 + match Eio.Process.await child with `Exited 0 -> true | _ -> false 362 491 in 363 492 result 364 493 365 494 (** Add a git remote *) 366 495 let add_remote ~proc ~fs ~repo ~name ~url () = 367 496 let cwd = Eio.Path.(fs / Fpath.to_string repo) in 368 368 - let cmd = ["git"; "remote"; "add"; name; Uri.to_string url] in 369 369 - Log.debug (fun m -> m "Running: %s (in %a)" (String.concat " " cmd) Fpath.pp repo); 497 497 + let cmd = [ "git"; "remote"; "add"; name; Uri.to_string url ] in 498 498 + Log.debug (fun m -> 499 499 + m "Running: %s (in %a)" (String.concat " " cmd) Fpath.pp repo); 370 500 Eio.Switch.run @@ fun sw -> 371 371 - let child = Eio.Process.spawn proc ~sw ~cwd 501 501 + let child = 502 502 + Eio.Process.spawn proc ~sw ~cwd 372 503 ~stdout:(Eio.Flow.buffer_sink (Buffer.create 16)) 373 504 ~stderr:(Eio.Flow.buffer_sink (Buffer.create 16)) 374 505 cmd ··· 377 508 | `Exited 0 -> Ok () 378 509 | _ -> Error "Failed to add remote" 379 510 380 380 - (** Fetch a remote *) 381 381 - let fetch_remote ~proc ~fs ~repo ~remote () = 382 382 - let cwd = Eio.Path.(fs / Fpath.to_string repo) in 383 383 - let cmd = ["git"; "fetch"; remote] in 384 384 - Log.info (fun m -> m "Fetching %s in %a" remote Fpath.pp repo); 385 385 - Log.debug (fun m -> m "Running: %s (in %a)" (String.concat " " cmd) Fpath.pp repo); 386 386 - Eio.Switch.run @@ fun sw -> 387 387 - let child = Eio.Process.spawn proc ~sw ~cwd 388 388 - ~stdout:(Eio.Flow.buffer_sink (Buffer.create 256)) 389 389 - ~stderr:(Eio.Flow.buffer_sink (Buffer.create 256)) 390 390 - cmd 391 391 - in 392 392 - match Eio.Process.await child with 393 393 - | `Exited 0 -> Ok () 394 394 - | _ -> Error "Failed to fetch remote" 511 511 + (** Fetch a remote (with caching) *) 512 512 + let fetch_remote ~proc ~fs ~repo ~remote ~refresh () = 513 513 + let cache_key = Printf.sprintf "checkout/%s/%s" (Fpath.to_string repo) remote in 514 514 + if not (needs_fetch ~refresh ~timeout:default_cache_timeout cache_key) then begin 515 515 + Log.debug (fun m -> m "Skipping fetch for %s in %a (cached)" remote Fpath.pp repo); 516 516 + Ok () (* Return Ok since we have cached data *) 517 517 + end else begin 518 518 + let cwd = Eio.Path.(fs / Fpath.to_string repo) in 519 519 + let cmd = ["git"; "fetch"; remote] in 520 520 + Log.info (fun m -> m "Fetching %s in %a" remote Fpath.pp repo); 521 521 + Log.debug (fun m -> m "Running: %s (in %a)" (String.concat " " cmd) Fpath.pp repo); 522 522 + Eio.Switch.run @@ fun sw -> 523 523 + let child = Eio.Process.spawn proc ~sw ~cwd 524 524 + ~stdout:(Eio.Flow.buffer_sink (Buffer.create 256)) 525 525 + ~stderr:(Eio.Flow.buffer_sink (Buffer.create 256)) 526 526 + cmd 527 527 + in 528 528 + match Eio.Process.await child with 529 529 + | `Exited 0 -> record_fetch cache_key; Ok () 530 530 + | _ -> Error "Failed to fetch remote" 531 531 + end 395 532 396 533 (** Get the commit SHA for a ref *) 397 534 let get_ref_commit ~proc ~fs ~repo ref_name = 398 535 let cwd = Eio.Path.(fs / Fpath.to_string repo) in 399 399 - let cmd = ["git"; "rev-parse"; ref_name] in 400 400 - Log.debug (fun m -> m "Running: %s (in %a)" (String.concat " " cmd) Fpath.pp repo); 536 536 + let cmd = [ "git"; "rev-parse"; ref_name ] in 537 537 + Log.debug (fun m -> 538 538 + m "Running: %s (in %a)" (String.concat " " cmd) Fpath.pp repo); 401 539 Eio.Switch.run @@ fun sw -> 402 540 let buf = Buffer.create 64 in 403 403 - let child = Eio.Process.spawn proc ~sw ~cwd 404 404 - ~stdout:(Eio.Flow.buffer_sink buf) 541 541 + let child = 542 542 + Eio.Process.spawn proc ~sw ~cwd ~stdout:(Eio.Flow.buffer_sink buf) 405 543 ~stderr:(Eio.Flow.buffer_sink (Buffer.create 16)) 406 544 cmd 407 545 in ··· 416 554 match (my_commit, their_commit) with 417 555 | None, _ | _, None -> Not_fetched 418 556 | Some my_sha, Some their_sha when my_sha = their_sha -> Same_commit 419 419 - | Some my_sha, Some their_sha -> 557 557 + | Some my_sha, Some their_sha -> ( 420 558 (* Check ancestry *) 421 559 let cwd = Eio.Path.(fs / Fpath.to_string repo) in 422 560 let is_ancestor commit1 commit2 = 423 423 - let cmd = ["git"; "merge-base"; "--is-ancestor"; commit1; commit2] in 424 424 - Log.debug (fun m -> m "Running: %s (in %a)" (String.concat " " cmd) Fpath.pp repo); 561 561 + let cmd = [ "git"; "merge-base"; "--is-ancestor"; commit1; commit2 ] in 562 562 + Log.debug (fun m -> 563 563 + m "Running: %s (in %a)" (String.concat " " cmd) Fpath.pp repo); 425 564 Eio.Switch.run @@ fun sw -> 426 426 - let child = Eio.Process.spawn proc ~sw ~cwd 565 565 + let child = 566 566 + Eio.Process.spawn proc ~sw ~cwd 427 567 ~stdout:(Eio.Flow.buffer_sink (Buffer.create 16)) 428 568 ~stderr:(Eio.Flow.buffer_sink (Buffer.create 16)) 429 569 cmd 430 570 in 431 431 - match Eio.Process.await child with 432 432 - | `Exited 0 -> true 433 433 - | _ -> false 571 571 + match Eio.Process.await child with `Exited 0 -> true | _ -> false 434 572 in 435 573 let count_commits base head = 436 436 - let cmd = ["git"; "rev-list"; "--count"; base ^ ".." ^ head] in 437 437 - Log.debug (fun m -> m "Running: %s (in %a)" (String.concat " " cmd) Fpath.pp repo); 574 574 + let cmd = [ "git"; "rev-list"; "--count"; base ^ ".." ^ head ] in 575 575 + Log.debug (fun m -> 576 576 + m "Running: %s (in %a)" (String.concat " " cmd) Fpath.pp repo); 438 577 Eio.Switch.run @@ fun sw -> 439 578 let buf = Buffer.create 16 in 440 440 - let child = Eio.Process.spawn proc ~sw ~cwd 441 441 - ~stdout:(Eio.Flow.buffer_sink buf) 579 579 + let child = 580 580 + Eio.Process.spawn proc ~sw ~cwd ~stdout:(Eio.Flow.buffer_sink buf) 442 581 ~stderr:(Eio.Flow.buffer_sink (Buffer.create 16)) 443 582 cmd 444 583 in 445 584 match Eio.Process.await child with 446 446 - | `Exited 0 -> (try int_of_string (String.trim (Buffer.contents buf)) with _ -> 0) 585 585 + | `Exited 0 -> ( 586 586 + try int_of_string (String.trim (Buffer.contents buf)) with _ -> 0) 447 587 | _ -> 0 448 588 in 449 589 let my_is_ancestor = is_ancestor my_sha their_sha in 450 590 let their_is_ancestor = is_ancestor their_sha my_sha in 451 591 match (my_is_ancestor, their_is_ancestor) with 452 452 - | true, true -> Same_commit (* shouldn't happen if SHAs differ *) 592 592 + | true, true -> Same_commit (* shouldn't happen if SHAs differ *) 453 593 | true, false -> 454 594 (* My commit is ancestor of theirs -> I'm behind *) 455 595 let behind = count_commits my_sha their_sha in ··· 458 598 (* Their commit is ancestor of mine -> I'm ahead *) 459 599 let ahead = count_commits their_sha my_sha in 460 600 I_am_ahead ahead 461 461 - | false, false -> 601 601 + | false, false -> ( 462 602 (* Check for common ancestor *) 463 463 - let cmd = ["git"; "merge-base"; my_sha; their_sha] in 464 464 - Log.debug (fun m -> m "Running: %s (in %a)" (String.concat " " cmd) Fpath.pp repo); 603 603 + let cmd = [ "git"; "merge-base"; my_sha; their_sha ] in 604 604 + Log.debug (fun m -> 605 605 + m "Running: %s (in %a)" (String.concat " " cmd) Fpath.pp repo); 465 606 let merge_base = 466 607 Eio.Switch.run @@ fun sw -> 467 608 let buf = Buffer.create 64 in 468 468 - let child = Eio.Process.spawn proc ~sw ~cwd 469 469 - ~stdout:(Eio.Flow.buffer_sink buf) 609 609 + let child = 610 610 + Eio.Process.spawn proc ~sw ~cwd ~stdout:(Eio.Flow.buffer_sink buf) 470 611 ~stderr:(Eio.Flow.buffer_sink (Buffer.create 16)) 471 612 cmd 472 613 in ··· 479 620 | Some base -> 480 621 let my_ahead = count_commits base my_sha in 481 622 let their_ahead = count_commits base their_sha in 482 482 - Diverged { common_ancestor = base; my_ahead; their_ahead } 623 623 + Diverged { common_ancestor = base; my_ahead; their_ahead })) 483 624 484 625 (** Compute fork analysis for all repos *) 485 485 - let compute ~proc ~fs ~verse_config ~monopam_config () = 626 626 + let compute ~proc ~fs ~verse_config ~monopam_config ?(refresh=false) () = 486 627 let verse_path = Verse_config.verse_path verse_config in 487 628 let opam_repo_path = Config.Paths.opam_repo monopam_config in 488 629 let checkouts_path = Config.Paths.checkouts monopam_config in ··· 493 634 494 635 (* Scan verse opam repos *) 495 636 Log.info (fun m -> m "Scanning verse opam repos"); 496 496 - let verse_repos = scan_all_verse_opam_repos ~proc ~fs ~verse_path () in 637 637 + let verse_repos = scan_all_verse_opam_repos ~proc ~fs ~verse_path ~refresh () in 497 638 498 639 (* Build combined list of all repo names *) 499 640 let all_repos = Hashtbl.create 64 in ··· 530 671 match my_source with 531 672 | Some my when urls_equal my.url src.url -> Same_url 532 673 | _ when not have_checkout -> Not_fetched 533 533 - | _ -> 674 674 + | _ -> ( 534 675 let remote_name = verse_remote_name src.handle in 535 676 (* Add remote if needed *) 536 536 - if not (remote_exists ~proc ~fs ~repo:checkout_path remote_name) then begin 537 537 - Log.info (fun m -> m "Adding remote %s -> %a" remote_name Uri.pp src.url); 538 538 - ignore (add_remote ~proc ~fs ~repo:checkout_path ~name:remote_name ~url:src.url ()) 677 677 + if 678 678 + not 679 679 + (remote_exists ~proc ~fs ~repo:checkout_path 680 680 + remote_name) 681 681 + then begin 682 682 + Log.info (fun m -> 683 683 + m "Adding remote %s -> %a" remote_name Uri.pp 684 684 + src.url); 685 685 + ignore 686 686 + (add_remote ~proc ~fs ~repo:checkout_path 687 687 + ~name:remote_name ~url:src.url ()) 539 688 end; 540 540 - (* Fetch remote *) 541 541 - (match fetch_remote ~proc ~fs ~repo:checkout_path ~remote:remote_name () with 689 689 + (* Fetch remote (respecting cache unless refresh) *) 690 690 + match fetch_remote ~proc ~fs ~repo:checkout_path ~remote:remote_name ~refresh () with 542 691 | Error _ -> Not_fetched 543 692 | Ok () -> 544 693 (* Compare refs *) 545 694 let my_ref = "origin/main" in 546 695 let their_ref = remote_name ^ "/main" in 547 547 - compare_refs ~proc ~fs ~repo:checkout_path ~my_ref ~their_ref ()) 696 696 + compare_refs ~proc ~fs ~repo:checkout_path ~my_ref 697 697 + ~their_ref ()) 548 698 in 549 699 (src.handle, src, rel)) 550 700 verse_sources ··· 554 704 all_repos [] 555 705 in 556 706 (* Sort by repo name *) 557 557 - let repos = List.sort (fun a b -> String.compare a.repo_name b.repo_name) analyses in 707 707 + let repos = 708 708 + List.sort (fun a b -> String.compare a.repo_name b.repo_name) analyses 709 709 + in 558 710 { repos }

+28 -27

lib/forks.mli

reviewed

··· 1 1 (** Fork graph discovery via verse opam repos. 2 2 3 3 - Scans verse opam repos to discover dev-repo URLs, adds git remotes 4 4 - to local checkouts, and computes fork relationships. *) 3 3 + Scans verse opam repos to discover dev-repo URLs, adds git remotes to local 4 4 + checkouts, and computes fork relationships. *) 5 5 6 6 (** {1 Types} *) 7 7 8 8 - (** A dev-repo source from a specific member *) 9 8 type repo_source = { 10 10 - handle : string; (** Member handle or "me" *) 11 11 - url : Uri.t; (** Normalized git URL *) 12 12 - packages : string list; (** Opam packages from this repo *) 9 9 + handle : string; (** Member handle or "me" *) 10 10 + url : Uri.t; (** Normalized git URL *) 11 11 + packages : string list; (** Opam packages from this repo *) 13 12 } 13 13 + (** A dev-repo source from a specific member *) 14 14 15 15 (** Fork relationship between two sources *) 16 16 type relationship = 17 17 - | Same_url (** Same git URL *) 18 18 - | Same_commit (** Different URLs but same HEAD *) 19 19 - | I_am_ahead of int (** They forked from me, I'm N commits ahead *) 20 20 - | I_am_behind of int (** I forked from them, they're N commits ahead *) 17 17 + | Same_url (** Same git URL *) 18 18 + | Same_commit (** Different URLs but same HEAD *) 19 19 + | I_am_ahead of int (** They forked from me, I'm N commits ahead *) 20 20 + | I_am_behind of int (** I forked from them, they're N commits ahead *) 21 21 | Diverged of { common_ancestor : string; my_ahead : int; their_ahead : int } 22 22 - | Unrelated (** No common history *) 23 23 - | Not_fetched (** Remote not yet fetched *) 22 22 + | Unrelated (** No common history *) 23 23 + | Not_fetched (** Remote not yet fetched *) 24 24 25 25 - (** Analysis result for a single repository *) 26 25 type repo_analysis = { 27 27 - repo_name : string; (** Repository basename *) 28 28 - my_source : repo_source option; (** My dev-repo if I have it *) 26 26 + repo_name : string; (** Repository basename *) 27 27 + my_source : repo_source option; (** My dev-repo if I have it *) 29 28 verse_sources : (string * repo_source * relationship) list; 30 30 - (** (handle, source, relationship to me) *) 29 29 + (** (handle, source, relationship to me) *) 31 30 } 31 31 + (** Analysis result for a single repository *) 32 32 33 33 + type t = { repos : repo_analysis list } 33 34 (** Full fork analysis result *) 34 34 - type t = { 35 35 - repos : repo_analysis list; 36 36 - } 37 35 38 36 (** {1 Pretty Printing} *) 39 37 40 38 val pp_relationship : relationship Fmt.t 41 39 val pp_repo_source : repo_source Fmt.t 42 40 val pp_repo_analysis : repo_analysis Fmt.t 41 41 + 43 42 val pp : t Fmt.t 44 43 (** Verbose output with full URLs for each repo. *) 45 44 46 45 val pp_summary : t Fmt.t 47 47 - (** Succinct summary: one line per repo with emphasis on repos where 48 48 - others have commits not in mine. *) 46 46 + (** Succinct summary: one line per repo with emphasis on repos where others have 47 47 + commits not in mine. *) 49 48 50 49 val pp_summary' : show_all:bool -> t Fmt.t 51 50 (** [pp_summary' ~show_all] formats a succinct summary. When [show_all] is true, 52 51 lists all repos that others have but you don't. *) 53 52 54 53 val is_actionable : relationship -> bool 55 55 - (** [is_actionable rel] returns [true] if the relationship indicates 56 56 - that others have commits I should consider pulling (I_am_behind or Diverged). *) 54 54 + (** [is_actionable rel] returns [true] if the relationship indicates that others 55 55 + have commits I should consider pulling (I_am_behind or Diverged). *) 57 56 58 57 (** {1 URL Utilities} *) 59 58 60 59 val normalize_url : Uri.t -> Uri.t 61 61 - (** [normalize_url url] normalizes a git URL for comparison. 62 62 - Converts SSH to HTTPS, strips git+ prefix and .git suffix. *) 60 60 + (** [normalize_url url] normalizes a git URL for comparison. Converts SSH to 61 61 + HTTPS, strips git+ prefix and .git suffix. *) 63 62 64 63 val urls_equal : Uri.t -> Uri.t -> bool 65 64 (** [urls_equal url1 url2] checks if two URLs refer to the same repo. *) ··· 74 73 fs:Eio.Fs.dir_ty Eio.Path.t -> 75 74 verse_config:Verse_config.t -> 76 75 monopam_config:Config.t -> 76 76 + ?refresh:bool -> 77 77 unit -> 78 78 t 79 79 - (** [compute ~proc ~fs ~verse_config ~monopam_config ()] performs full fork 79 79 + (** [compute ~proc ~fs ~verse_config ~monopam_config ?refresh ()] performs full fork 80 80 analysis by: 81 81 1. Scanning my opam repo for dev-repo URLs 82 82 2. Scanning all verse opam repos for dev-repo URLs 83 83 3. Adding git remotes to my checkouts for each member's fork 84 84 4. Fetching remotes and comparing commit histories 85 85 86 86 - This is an expensive operation as it fetches from all verse member remotes. *) 86 86 + Fetches are cached for 1 hour by default. Use [~refresh:true] to force 87 87 + fresh fetches from all remotes. *)

+222 -56

lib/git.ml

reviewed

··· 1 1 - (* Convert Uri.t to string for git commands, handling SSH URLs properly. 2 2 - Uri.to_string percent-encodes special characters like @, but SSH URLs 3 3 - like git@host:path need to be passed through unencoded. *) 4 4 - let uri_to_git_url url = 5 5 - let s = Uri.to_string url in 6 6 - Uri.pct_decode s 7 7 - 8 1 type cmd_result = { exit_code : int; stdout : string; stderr : string } 9 2 10 3 type error = ··· 57 50 let result = run_git ~proc ~cwd args in 58 51 if result.exit_code = 0 then Ok result.stdout 59 52 else Error (Command_failed (String.concat " " ("git" :: args), result)) 53 53 + 54 54 + (** Helper for substring check *) 55 55 + let string_contains ~needle haystack = 56 56 + let needle_len = String.length needle in 57 57 + let haystack_len = String.length haystack in 58 58 + if needle_len > haystack_len then false 59 59 + else 60 60 + let rec check i = 61 61 + if i + needle_len > haystack_len then false 62 62 + else if String.sub haystack i needle_len = needle then true 63 63 + else check (i + 1) 64 64 + in 65 65 + check 0 66 66 + 67 67 + (** Check if an error is a retryable HTTP server error (5xx) or network error *) 68 68 + let is_retryable_error result = 69 69 + let stderr = result.stderr in 70 70 + (* Common patterns for HTTP 5xx errors in git output *) 71 71 + String.length stderr > 0 && 72 72 + (string_contains ~needle:"500" stderr || 73 73 + string_contains ~needle:"502" stderr || 74 74 + string_contains ~needle:"503" stderr || 75 75 + string_contains ~needle:"504" stderr || 76 76 + string_contains ~needle:"HTTP 5" stderr || 77 77 + string_contains ~needle:"http 5" stderr || 78 78 + string_contains ~needle:"Internal Server Error" stderr || 79 79 + string_contains ~needle:"Bad Gateway" stderr || 80 80 + string_contains ~needle:"Service Unavailable" stderr || 81 81 + string_contains ~needle:"Gateway Timeout" stderr || 82 82 + (* RPC failures (common git smart HTTP errors) *) 83 83 + string_contains ~needle:"RPC failed" stderr || 84 84 + string_contains ~needle:"curl" stderr || 85 85 + string_contains ~needle:"unexpected disconnect" stderr || 86 86 + string_contains ~needle:"the remote end hung up" stderr || 87 87 + string_contains ~needle:"early EOF" stderr || 88 88 + (* Connection errors *) 89 89 + string_contains ~needle:"Connection refused" stderr || 90 90 + string_contains ~needle:"Connection reset" stderr || 91 91 + string_contains ~needle:"Connection timed out" stderr || 92 92 + string_contains ~needle:"Could not resolve host" stderr || 93 93 + string_contains ~needle:"Failed to connect" stderr || 94 94 + string_contains ~needle:"Network is unreachable" stderr || 95 95 + string_contains ~needle:"Temporary failure" stderr) 96 96 + 97 97 + (** Run a git command with retry logic for network errors. 98 98 + Retries up to [max_retries] times with exponential backoff starting at [initial_delay_ms]. *) 99 99 + let run_git_ok_with_retry ~proc ~cwd ?(max_retries = 3) ?(initial_delay_ms = 2000) args = 100 100 + let rec attempt n delay_ms = 101 101 + let result = run_git ~proc ~cwd args in 102 102 + if result.exit_code = 0 then Ok result.stdout 103 103 + else if n < max_retries && is_retryable_error result then begin 104 104 + (* Log the retry *) 105 105 + Logs.warn (fun m -> 106 106 + m "Git command failed with retryable error, retrying in %dms (%d/%d): %s" 107 107 + delay_ms (n + 1) max_retries result.stderr); 108 108 + (* Sleep before retry - convert ms to seconds for Unix.sleepf *) 109 109 + Unix.sleepf (float_of_int delay_ms /. 1000.0); 110 110 + (* Exponential backoff: double the delay for next attempt *) 111 111 + attempt (n + 1) (delay_ms * 2) 112 112 + end 113 113 + else Error (Command_failed (String.concat " " ("git" :: args), result)) 114 114 + in 115 115 + attempt 0 initial_delay_ms 60 116 61 117 let path_to_eio ~(fs : Eio.Fs.dir_ty Eio.Path.t) path = 62 118 let dir, _ = fs in ··· 67 123 try 68 124 let result = run_git ~proc ~cwd [ "rev-parse"; "--git-dir" ] in 69 125 result.exit_code = 0 70 70 - with Eio.Io _ -> false (* Directory doesn't exist or not accessible *) 126 126 + with Eio.Io _ -> false (* Directory doesn't exist or not accessible *) 71 127 72 128 let is_dirty ~proc ~fs path = 73 129 let cwd = path_to_eio ~fs path in ··· 91 147 let parent = Fpath.parent target in 92 148 let cwd = Eio.Path.(fs / Fpath.to_string parent) in 93 149 let target_name = Fpath.basename target in 94 94 - let url_str = uri_to_git_url url in 95 95 - run_git_ok ~proc ~cwd [ "clone"; "--branch"; branch; url_str; target_name ] 150 150 + let url_str = Uri.to_string url in 151 151 + run_git_ok_with_retry ~proc ~cwd [ "clone"; "--branch"; branch; url_str; target_name ] 96 152 |> Result.map ignore 97 153 98 154 let fetch ~proc ~fs ?(remote = "origin") path = 99 155 let cwd = path_to_eio ~fs path in 100 100 - run_git_ok ~proc ~cwd [ "fetch"; remote ] |> Result.map ignore 156 156 + run_git_ok_with_retry ~proc ~cwd [ "fetch"; remote ] |> Result.map ignore 101 157 102 158 let fetch_all ~proc ~fs path = 103 159 let cwd = path_to_eio ~fs path in 104 104 - run_git_ok ~proc ~cwd [ "fetch"; "--all" ] |> Result.map ignore 160 160 + run_git_ok_with_retry ~proc ~cwd [ "fetch"; "--all" ] |> Result.map ignore 105 161 106 162 let merge_ff ~proc ~fs ?(remote = "origin") ?branch path = 107 163 let cwd = path_to_eio ~fs path in ··· 120 176 | Some b -> [ "pull"; remote; b ] 121 177 | None -> [ "pull"; remote ] 122 178 in 123 123 - run_git_ok ~proc ~cwd args |> Result.map ignore 179 179 + run_git_ok_with_retry ~proc ~cwd args |> Result.map ignore 124 180 125 181 let fetch_and_reset ~proc ~fs ?(remote = "origin") ~branch path = 126 182 let cwd = path_to_eio ~fs path in 127 127 - match run_git_ok ~proc ~cwd [ "fetch"; remote ] with 183 183 + match run_git_ok_with_retry ~proc ~cwd [ "fetch"; remote ] with 128 184 | Error e -> Error e 129 185 | Ok _ -> 130 186 let upstream = remote ^ "/" ^ branch in ··· 167 223 if exists ~fs ~repo ~prefix then Error (Subtree_prefix_exists prefix) 168 224 else 169 225 let cwd = path_to_eio ~fs repo in 170 170 - let url_str = uri_to_git_url url in 171 171 - run_git_ok ~proc ~cwd 226 226 + let url_str = Uri.to_string url in 227 227 + run_git_ok_with_retry ~proc ~cwd 172 228 [ "subtree"; "add"; "--prefix"; prefix; url_str; branch; "--squash" ] 173 229 |> Result.map ignore 174 230 ··· 176 232 if not (exists ~fs ~repo ~prefix) then Error (Subtree_prefix_missing prefix) 177 233 else 178 234 let cwd = path_to_eio ~fs repo in 179 179 - let url_str = uri_to_git_url url in 180 180 - run_git_ok ~proc ~cwd 235 235 + let url_str = Uri.to_string url in 236 236 + run_git_ok_with_retry ~proc ~cwd 181 237 [ "subtree"; "pull"; "--prefix"; prefix; url_str; branch; "--squash" ] 182 238 |> Result.map ignore 183 239 ··· 185 241 if not (exists ~fs ~repo ~prefix) then Error (Subtree_prefix_missing prefix) 186 242 else 187 243 let cwd = path_to_eio ~fs repo in 188 188 - let url_str = uri_to_git_url url in 189 189 - run_git_ok ~proc ~cwd 244 244 + let url_str = Uri.to_string url in 245 245 + run_git_ok_with_retry ~proc ~cwd 190 246 [ "subtree"; "push"; "--prefix"; prefix; url_str; branch ] 191 247 |> Result.map ignore 192 248 ··· 214 270 | Some b -> b 215 271 | None -> Option.value ~default:"main" (current_branch ~proc ~fs path) 216 272 in 217 217 - run_git_ok ~proc ~cwd [ "push"; remote; branch ] |> Result.map ignore 273 273 + run_git_ok_with_retry ~proc ~cwd [ "push"; remote; branch ] |> Result.map ignore 274 274 + 275 275 + let push_ref ~proc ~fs ~repo ~target ~ref_spec () = 276 276 + let cwd = path_to_eio ~fs repo in 277 277 + run_git_ok ~proc ~cwd [ "push"; target; ref_spec ] |> Result.map ignore 218 278 219 279 let set_push_url ~proc ~fs ?(remote = "origin") ~url path = 220 280 let cwd = path_to_eio ~fs path in ··· 243 303 244 304 let add_remote ~proc ~fs ~name ~url path = 245 305 let cwd = path_to_eio ~fs path in 246 246 - run_git_ok ~proc ~cwd [ "remote"; "add"; name; url ] 247 247 - |> Result.map ignore 306 306 + run_git_ok ~proc ~cwd [ "remote"; "add"; name; url ] |> Result.map ignore 248 307 249 308 let remove_remote ~proc ~fs ~name path = 250 309 let cwd = path_to_eio ~fs path in 251 251 - run_git_ok ~proc ~cwd [ "remote"; "remove"; name ] 252 252 - |> Result.map ignore 310 310 + run_git_ok ~proc ~cwd [ "remote"; "remove"; name ] |> Result.map ignore 253 311 254 312 let set_remote_url ~proc ~fs ~name ~url path = 255 313 let cwd = path_to_eio ~fs path in 256 256 - run_git_ok ~proc ~cwd [ "remote"; "set-url"; name; url ] 257 257 - |> Result.map ignore 314 314 + run_git_ok ~proc ~cwd [ "remote"; "set-url"; name; url ] |> Result.map ignore 258 315 259 316 let ensure_remote ~proc ~fs ~name ~url path = 260 317 let remotes = list_remotes ~proc ~fs path in ··· 264 321 | Some existing_url when existing_url = url -> Ok () 265 322 | _ -> set_remote_url ~proc ~fs ~name ~url path 266 323 end 267 267 - else 268 268 - add_remote ~proc ~fs ~name ~url path 324 324 + else add_remote ~proc ~fs ~name ~url path 269 325 270 326 type log_entry = { 271 327 hash : string; ··· 311 367 let args = 312 368 match until with Some u -> args @ [ "--until=" ^ u ] | None -> args 313 369 in 314 314 - let args = match filter_path with Some p -> args @ [ "--"; p ] | None -> args in 370 370 + let args = 371 371 + match filter_path with Some p -> args @ [ "--"; p ] | None -> args 372 372 + in 315 373 match run_git_ok ~proc ~cwd args with 316 374 | Ok output -> Ok (parse_log_entries output) 317 375 | Error e -> Error e ··· 321 379 let format_arg = "--format=%H%n%an%n%aI%n%s%n%b%x00" in 322 380 let range = Printf.sprintf "%s..%s" base tip in 323 381 let args = [ "log"; format_arg; range ] in 324 324 - let args = match max_count with 382 382 + let args = 383 383 + match max_count with 325 384 | Some n -> args @ [ "-n"; string_of_int n ] 326 385 | None -> args 327 386 in ··· 329 388 | Ok output -> Ok (parse_log_entries output) 330 389 | Error e -> Error e 331 390 391 391 + let show_patch ~proc ~fs ~commit repo_path = 392 392 + let cwd = path_to_eio ~fs repo_path in 393 393 + run_git_ok ~proc ~cwd [ "show"; "--patch"; "--stat"; commit ] 394 394 + 332 395 (** Parse a subtree merge/squash commit message to extract the upstream commit range. 333 396 Messages look like: "Squashed 'prefix/' changes from abc123..def456" 334 397 or "Squashed 'prefix/' content from commit abc123" ··· 339 402 let len = String.length s in 340 403 let rec find_end i = 341 404 if i >= len then i 342 342 - else match s.[i] with 343 343 - | '0'..'9' | 'a'..'f' -> find_end (i + 1) 344 344 - | _ -> i 405 405 + else 406 406 + match s.[i] with '0' .. '9' | 'a' .. 'f' -> find_end (i + 1) | _ -> i 345 407 in 346 408 let end_pos = find_end start in 347 409 if end_pos > start then Some (String.sub s start (end_pos - start)) ··· 352 414 match String.index_opt subject '.' with 353 415 | Some i when i + 1 < String.length subject && subject.[i + 1] = '.' -> 354 416 extract_hex subject (i + 2) 355 355 - | _ -> 417 417 + | _ -> ( 356 418 (* Pattern 2: "Squashed 'prefix/' content from commit abc123" *) 357 357 - (match String.split_on_char ' ' subject |> List.rev with 419 419 + match String.split_on_char ' ' subject |> List.rev with 358 420 | last :: "commit" :: "from" :: _ -> extract_hex last 0 359 359 - | _ -> None) 360 360 - (* Pattern 3: "Add 'prefix/' from commit abc123" *) 421 421 + | _ -> None) (* Pattern 3: "Add 'prefix/' from commit abc123" *) 361 422 else if String.starts_with ~prefix:"Add '" subject then 362 423 match String.split_on_char ' ' subject |> List.rev with 363 424 | last :: "commit" :: "from" :: _ -> extract_hex last 0 364 425 | _ -> None 365 365 - else 366 366 - None 426 426 + else None 367 427 368 368 - (** Find the last subtree-related commit for a given prefix. 369 369 - Searches git log for commits with subtree merge/squash messages. *) 428 428 + (** Find the last subtree-related commit for a given prefix. Searches git log 429 429 + for commits with subtree merge/squash messages. *) 370 430 let subtree_last_upstream_commit ~proc ~fs ~repo ~prefix () = 371 431 let cwd = path_to_eio ~fs repo in 372 432 (* Search for subtree-related commits - don't use path filter as it can miss merge commits *) 373 433 let grep_pattern = Printf.sprintf "^Squashed '%s/'" prefix in 374 374 - match run_git_ok ~proc ~cwd 375 375 - [ "log"; "--oneline"; "-1"; "--grep"; grep_pattern ] with 434 434 + match 435 435 + run_git_ok ~proc ~cwd [ "log"; "--oneline"; "-1"; "--grep"; grep_pattern ] 436 436 + with 376 437 | Error _ -> None 377 377 - | Ok "" -> 438 438 + | Ok "" -> ( 378 439 (* Try alternate pattern: Add 'prefix/' from commit *) 379 440 let add_pattern = Printf.sprintf "^Add '%s/'" prefix in 380 380 - (match run_git_ok ~proc ~cwd 381 381 - [ "log"; "--oneline"; "-1"; "--grep"; add_pattern ] with 441 441 + match 442 442 + run_git_ok ~proc ~cwd 443 443 + [ "log"; "--oneline"; "-1"; "--grep"; add_pattern ] 444 444 + with 382 445 | Error _ -> None 383 446 | Ok "" -> None 384 384 - | Ok line -> 447 447 + | Ok line -> ( 385 448 (* line is "abc1234 Add 'prefix/' from commit ..." *) 386 449 let hash = String.sub line 0 (min 7 (String.length line)) in 387 450 (* Get the full commit message to parse *) 388 451 match run_git_ok ~proc ~cwd [ "log"; "-1"; "--format=%s"; hash ] with 389 452 | Error _ -> None 390 390 - | Ok subject -> parse_subtree_message subject) 391 391 - | Ok line -> 453 453 + | Ok subject -> parse_subtree_message subject)) 454 454 + | Ok line -> ( 392 455 let hash = String.sub line 0 (min 7 (String.length line)) in 393 456 match run_git_ok ~proc ~cwd [ "log"; "-1"; "--format=%s"; hash ] with 394 457 | Error _ -> None 395 395 - | Ok subject -> parse_subtree_message subject 458 458 + | Ok subject -> parse_subtree_message subject) 396 459 397 460 (** Check if commit1 is an ancestor of commit2. *) 398 461 let is_ancestor ~proc ~fs ~repo ~commit1 ~commit2 () = 399 462 let cwd = path_to_eio ~fs repo in 400 400 - let result = run_git ~proc ~cwd 401 401 - [ "merge-base"; "--is-ancestor"; commit1; commit2 ] in 463 463 + let result = 464 464 + run_git ~proc ~cwd [ "merge-base"; "--is-ancestor"; commit1; commit2 ] 465 465 + in 402 466 result.exit_code = 0 403 467 404 468 (** Find the merge-base (common ancestor) of two commits. *) ··· 409 473 (** Count commits between two commits (exclusive of base, inclusive of head). *) 410 474 let count_commits_between ~proc ~fs ~repo ~base ~head () = 411 475 let cwd = path_to_eio ~fs repo in 412 412 - match run_git_ok ~proc ~cwd 413 413 - [ "rev-list"; "--count"; base ^ ".." ^ head ] with 476 476 + match run_git_ok ~proc ~cwd [ "rev-list"; "--count"; base ^ ".." ^ head ] with 414 477 | Error _ -> 0 415 415 - | Ok s -> try int_of_string (String.trim s) with _ -> 0 478 478 + | Ok s -> ( try int_of_string (String.trim s) with _ -> 0) 479 479 + 480 480 + (** {1 Worktree Operations} *) 416 481 417 482 module Worktree = struct 418 483 type entry = { ··· 495 560 let worktrees = list ~proc ~fs repo in 496 561 List.exists (fun e -> Fpath.equal e.path path) worktrees 497 562 end 563 563 + 564 564 + let cherry_pick ~proc ~fs ~commit path = 565 565 + let cwd = path_to_eio ~fs path in 566 566 + run_git_ok ~proc ~cwd [ "cherry-pick"; commit ] |> Result.map ignore 567 567 + 568 568 + let merge ~proc ~fs ~ref_name ?(ff_only=false) path = 569 569 + let cwd = path_to_eio ~fs path in 570 570 + let args = ["merge"] @ (if ff_only then ["--ff-only"] else []) @ [ref_name] in 571 571 + run_git_ok ~proc ~cwd args |> Result.map ignore 572 572 + 573 573 + (** {1 Diff Operations} *) 574 574 + 575 575 + let diff_trees ~proc ~fs ~source ~target = 576 576 + (* Use git diff --no-index to compare two directory trees. 577 577 + This works even if neither directory is a git repo. 578 578 + Exit code 0 = no diff, exit code 1 = diff found, other = error *) 579 579 + let cwd = path_to_eio ~fs (Fpath.v ".") in 580 580 + let source_str = Fpath.to_string source in 581 581 + let target_str = Fpath.to_string target in 582 582 + let result = 583 583 + run_git ~proc ~cwd 584 584 + [ 585 585 + "diff"; 586 586 + "--no-index"; 587 587 + "--binary"; 588 588 + (* Handle binary files *) 589 589 + "--no-color"; 590 590 + target_str; 591 591 + (* old = checkout *) 592 592 + source_str (* new = monorepo subtree *); 593 593 + ] 594 594 + in 595 595 + match result.exit_code with 596 596 + | 0 -> 597 597 + (* No differences *) 598 598 + Ok "" 599 599 + | 1 -> 600 600 + (* Differences found - this is success for diff *) 601 601 + Ok result.stdout 602 602 + | _ -> 603 603 + (* Actual error *) 604 604 + Error 605 605 + (Command_failed 606 606 + (String.concat " " [ "git"; "diff"; "--no-index" ], result)) 607 607 + 608 608 + let apply_diff ~proc ~fs ~cwd ~diff = 609 609 + if String.length diff = 0 then Ok () 610 610 + else 611 611 + let cwd_eio = path_to_eio ~fs cwd in 612 612 + (* Apply the diff using git apply. 613 613 + We need to handle the path rewriting since git diff --no-index 614 614 + uses absolute or relative paths as prefixes. *) 615 615 + let cmd = [ "apply"; "--binary"; "-p1"; "-" ] in 616 616 + let buf_stdout = Buffer.create 256 in 617 617 + let buf_stderr = Buffer.create 256 in 618 618 + Eio.Switch.run @@ fun sw -> 619 619 + let child = 620 620 + Eio.Process.spawn proc ~sw ~cwd:cwd_eio 621 621 + ~stdin:(Eio.Flow.string_source diff) 622 622 + ~stdout:(Eio.Flow.buffer_sink buf_stdout) 623 623 + ~stderr:(Eio.Flow.buffer_sink buf_stderr) 624 624 + ("git" :: cmd) 625 625 + in 626 626 + let exit_status = Eio.Process.await child in 627 627 + match exit_status with 628 628 + | `Exited 0 -> Ok () 629 629 + | `Exited n | `Signaled n -> 630 630 + Error 631 631 + (Command_failed 632 632 + ( String.concat " " ("git" :: cmd), 633 633 + { 634 634 + exit_code = n; 635 635 + stdout = Buffer.contents buf_stdout; 636 636 + stderr = Buffer.contents buf_stderr; 637 637 + } )) 638 638 + 639 639 + let add_all ~proc ~fs path = 640 640 + let cwd = path_to_eio ~fs path in 641 641 + run_git_ok ~proc ~cwd [ "add"; "-A" ] |> Result.map ignore 642 642 + 643 643 + let commit ~proc ~fs ~message path = 644 644 + let cwd = path_to_eio ~fs path in 645 645 + run_git_ok ~proc ~cwd [ "commit"; "-m"; message ] |> Result.map ignore 646 646 + 647 647 + let rm ~proc ~fs ~recursive path target = 648 648 + let cwd = path_to_eio ~fs path in 649 649 + let args = if recursive then [ "rm"; "-r"; target ] else [ "rm"; target ] in 650 650 + run_git_ok ~proc ~cwd args |> Result.map ignore 651 651 + 652 652 + let config ~proc ~fs ~key ~value path = 653 653 + let cwd = path_to_eio ~fs path in 654 654 + run_git_ok ~proc ~cwd [ "config"; key; value ] |> Result.map ignore 655 655 + 656 656 + let has_subtree_history ~proc ~fs ~repo ~prefix () = 657 657 + (* Check if there's subtree commit history for this prefix. 658 658 + Returns true if we can find a subtree-related commit message. *) 659 659 + subtree_last_upstream_commit ~proc ~fs ~repo ~prefix () |> Option.is_some 660 660 + 661 661 + let branch_rename ~proc ~fs ~new_name path = 662 662 + let cwd = path_to_eio ~fs path in 663 663 + run_git_ok ~proc ~cwd [ "branch"; "-M"; new_name ] |> Result.map ignore

+146 -7

lib/git.mli

reviewed

··· 274 274 @param remote Remote name (default: "origin") 275 275 @param branch Branch to push (default: current branch) *) 276 276 277 277 + val push_ref : 278 278 + proc:_ Eio.Process.mgr -> 279 279 + fs:Eio.Fs.dir_ty Eio.Path.t -> 280 280 + repo:Fpath.t -> 281 281 + target:string -> 282 282 + ref_spec:string -> 283 283 + unit -> 284 284 + (unit, error) result 285 285 + (** [push_ref ~proc ~fs ~repo ~target ~ref_spec ()] pushes a specific ref to a 286 286 + target repository or path. 287 287 + 288 288 + @param repo Path to the git repository to push from 289 289 + @param target Target repository path or remote name 290 290 + @param ref_spec The refspec to push (e.g., "abc123:refs/heads/main") *) 291 291 + 277 292 val set_push_url : 278 293 proc:_ Eio.Process.mgr -> 279 294 fs:Eio.Fs.dir_ty Eio.Path.t -> ··· 293 308 ?remote:string -> 294 309 Fpath.t -> 295 310 string option 296 296 - (** [get_push_url ~proc ~fs ?remote path] returns the push URL for a remote, 297 297 - or [None] if not set or the remote doesn't exist. 311 311 + (** [get_push_url ~proc ~fs ?remote path] returns the push URL for a remote, or 312 312 + [None] if not set or the remote doesn't exist. 298 313 299 314 @param remote Remote name (default: "origin") *) 300 315 ··· 339 354 url:string -> 340 355 Fpath.t -> 341 356 (unit, error) result 342 342 - (** [set_remote_url ~proc ~fs ~name ~url path] updates the URL for an existing remote. *) 357 357 + (** [set_remote_url ~proc ~fs ~name ~url path] updates the URL for an existing 358 358 + remote. *) 343 359 344 360 val ensure_remote : 345 361 proc:_ Eio.Process.mgr -> ··· 348 364 url:string -> 349 365 Fpath.t -> 350 366 (unit, error) result 351 351 - (** [ensure_remote ~proc ~fs ~name ~url path] ensures a remote exists with the given URL. 352 352 - If the remote exists with a different URL, it is updated. 353 353 - If the remote doesn't exist, it is added. *) 367 367 + (** [ensure_remote ~proc ~fs ~name ~url path] ensures a remote exists with the 368 368 + given URL. If the remote exists with a different URL, it is updated. If the 369 369 + remote doesn't exist, it is added. *) 354 370 355 371 (** {1 Commit History} *) 356 372 ··· 386 402 ?max_count:int -> 387 403 Fpath.t -> 388 404 (log_entry list, error) result 389 389 - (** [log_range ~proc ~fs ~base ~tip ?max_count repo] retrieves commits between refs. 405 405 + (** [log_range ~proc ~fs ~base ~tip ?max_count repo] retrieves commits between 406 406 + refs. 390 407 391 408 Gets commits reachable from [tip] but not from [base] (i.e., [base..tip]). 392 409 ··· 395 412 @param max_count Maximum number of commits to return 396 413 @param repo Path to the git repository *) 397 414 415 415 + val show_patch : 416 416 + proc:_ Eio.Process.mgr -> 417 417 + fs:Eio.Fs.dir_ty Eio.Path.t -> 418 418 + commit:string -> 419 419 + Fpath.t -> 420 420 + (string, error) result 421 421 + (** [show_patch ~proc ~fs ~commit repo] returns the patch content for a commit. 422 422 + 423 423 + Runs [git show --patch --stat commit] to get the full diff with stats. *) 424 424 + 398 425 (** {1 Subtree Commit Analysis} *) 399 426 400 427 val parse_subtree_message : string -> string option ··· 514 541 bool 515 542 (** [exists ~proc ~fs ~repo ~path] returns true if a worktree exists at [path]. *) 516 543 end 544 544 + 545 545 + (** {1 Cherry-pick Operations} *) 546 546 + 547 547 + val cherry_pick : 548 548 + proc:_ Eio.Process.mgr -> 549 549 + fs:Eio.Fs.dir_ty Eio.Path.t -> 550 550 + commit:string -> 551 551 + Fpath.t -> 552 552 + (unit, error) result 553 553 + (** [cherry_pick ~proc ~fs ~commit path] applies a single commit to the current branch. 554 554 + 555 555 + @param commit The commit hash to cherry-pick 556 556 + @param path Path to the repository *) 557 557 + 558 558 + val merge : 559 559 + proc:_ Eio.Process.mgr -> 560 560 + fs:Eio.Fs.dir_ty Eio.Path.t -> 561 561 + ref_name:string -> 562 562 + ?ff_only:bool -> 563 563 + Fpath.t -> 564 564 + (unit, error) result 565 565 + (** [merge ~proc ~fs ~ref_name ?ff_only path] merges a ref into the current branch. 566 566 + 567 567 + @param ref_name The ref to merge (e.g., "verse/handle/main") 568 568 + @param ff_only If true, only allow fast-forward merges (default: false) 569 569 + @param path Path to the repository *) 570 570 + 571 571 + (** {1 Diff Operations} *) 572 572 + 573 573 + val diff_trees : 574 574 + proc:_ Eio.Process.mgr -> 575 575 + fs:Eio.Fs.dir_ty Eio.Path.t -> 576 576 + source:Fpath.t -> 577 577 + target:Fpath.t -> 578 578 + (string, error) result 579 579 + (** [diff_trees ~proc ~fs ~source ~target] generates a diff between two 580 580 + directory trees using [git diff --no-index]. 581 581 + 582 582 + Returns [Ok ""] if the trees are identical, [Ok diff] with the diff content 583 583 + if they differ, or [Error] if the diff command fails. 584 584 + 585 585 + @param source The source directory (typically the monorepo subtree) 586 586 + @param target The target directory (typically the checkout) *) 587 587 + 588 588 + val apply_diff : 589 589 + proc:_ Eio.Process.mgr -> 590 590 + fs:Eio.Fs.dir_ty Eio.Path.t -> 591 591 + cwd:Fpath.t -> 592 592 + diff:string -> 593 593 + (unit, error) result 594 594 + (** [apply_diff ~proc ~fs ~cwd ~diff] applies a diff to the directory at [cwd]. 595 595 + 596 596 + Uses [git apply] to apply the diff. Returns [Ok ()] if the diff was applied 597 597 + successfully or was empty, [Error] if the apply failed. *) 598 598 + 599 599 + val add_all : 600 600 + proc:_ Eio.Process.mgr -> 601 601 + fs:Eio.Fs.dir_ty Eio.Path.t -> 602 602 + Fpath.t -> 603 603 + (unit, error) result 604 604 + (** [add_all ~proc ~fs path] stages all changes (git add -A) in the repository 605 605 + at [path]. *) 606 606 + 607 607 + val commit : 608 608 + proc:_ Eio.Process.mgr -> 609 609 + fs:Eio.Fs.dir_ty Eio.Path.t -> 610 610 + message:string -> 611 611 + Fpath.t -> 612 612 + (unit, error) result 613 613 + (** [commit ~proc ~fs ~message path] creates a commit with the given message 614 614 + in the repository at [path]. *) 615 615 + 616 616 + val rm : 617 617 + proc:_ Eio.Process.mgr -> 618 618 + fs:Eio.Fs.dir_ty Eio.Path.t -> 619 619 + recursive:bool -> 620 620 + Fpath.t -> 621 621 + string -> 622 622 + (unit, error) result 623 623 + (** [rm ~proc ~fs ~recursive path target] removes [target] from the git index 624 624 + in the repository at [path]. If [recursive] is true, removes directories 625 625 + recursively (git rm -r). *) 626 626 + 627 627 + val config : 628 628 + proc:_ Eio.Process.mgr -> 629 629 + fs:Eio.Fs.dir_ty Eio.Path.t -> 630 630 + key:string -> 631 631 + value:string -> 632 632 + Fpath.t -> 633 633 + (unit, error) result 634 634 + (** [config ~proc ~fs ~key ~value path] sets a git config value in the 635 635 + repository at [path]. *) 636 636 + 637 637 + val has_subtree_history : 638 638 + proc:_ Eio.Process.mgr -> 639 639 + fs:Eio.Fs.dir_ty Eio.Path.t -> 640 640 + repo:Fpath.t -> 641 641 + prefix:string -> 642 642 + unit -> 643 643 + bool 644 644 + (** [has_subtree_history ~proc ~fs ~repo ~prefix ()] returns true if the 645 645 + prefix has subtree commit history (i.e., was added via git subtree add). 646 646 + Returns false for fresh local packages that were never part of a subtree. *) 647 647 + 648 648 + val branch_rename : 649 649 + proc:_ Eio.Process.mgr -> 650 650 + fs:Eio.Fs.dir_ty Eio.Path.t -> 651 651 + new_name:string -> 652 652 + Fpath.t -> 653 653 + (unit, error) result 654 654 + (** [branch_rename ~proc ~fs ~new_name path] renames the current branch 655 655 + to [new_name] in the repository at [path]. Uses [git branch -M]. *)

+1393 -459

lib/monopam.ml

reviewed

··· 11 11 module Forks = Forks 12 12 module Doctor = Doctor 13 13 module Feature = Feature 14 14 + module Dune_project = Dune_project 15 15 + module Opam_transform = Opam_transform 16 16 + module Sources_registry = Sources_registry 17 17 + module Fork_join = Fork_join 18 18 + module Site = Site 14 19 15 20 let src = Logs.Src.create "monopam" ~doc:"Monopam operations" 16 21 ··· 21 26 | Repo_error of Opam_repo.error 22 27 | Git_error of Git.error 23 28 | Dirty_state of Package.t list 29 29 + | Monorepo_dirty 24 30 | Package_not_found of string 25 31 | Claude_error of string 26 32 ··· 32 38 Fmt.pf ppf "Dirty packages: %a" 33 39 Fmt.(list ~sep:comma (using Package.name string)) 34 40 pkgs 41 41 + | Monorepo_dirty -> Fmt.pf ppf "Monorepo has uncommitted changes" 35 42 | Package_not_found name -> Fmt.pf ppf "Package not found: %s" name 36 43 | Claude_error msg -> Fmt.pf ppf "Claude error: %s" msg 37 44 38 38 - (** Returns a hint string for the given error, or None if no hint is available. *) 45 45 + (** Returns a hint string for the given error, or None if no hint is available. 46 46 + *) 39 47 let error_hint = function 40 48 | Config_error _ -> 41 41 - Some "Run 'monopam verse init --handle <your-handle>' to create a workspace." 49 49 + Some 50 50 + "Run 'monopam init --handle <your-handle>' to create a workspace." 42 51 | Repo_error (Opam_repo.No_dev_repo _) -> 43 43 - Some "Add a 'dev-repo' field to the package's opam file pointing to a git URL." 52 52 + Some 53 53 + "Add a 'dev-repo' field to the package's opam file pointing to a git \ 54 54 + URL." 44 55 | Repo_error (Opam_repo.Not_git_remote _) -> 45 56 Some "The dev-repo must be a git URL (git+https:// or git://)." 46 57 | Repo_error _ -> None ··· 54 65 Some "Check that the remote is configured: git remote -v" 55 66 | Git_error (Git.Branch_not_found _) -> 56 67 Some "Check available branches: git branch -a" 57 57 - | Git_error (Git.Command_failed (cmd, _)) when String.starts_with ~prefix:"git push" cmd -> 68 68 + | Git_error (Git.Command_failed (cmd, _)) 69 69 + when String.starts_with ~prefix:"git push" cmd -> 58 70 Some "Check your network connection and git credentials." 59 59 - | Git_error (Git.Command_failed (cmd, _)) when String.starts_with ~prefix:"git subtree" cmd -> 71 71 + | Git_error (Git.Command_failed (cmd, _)) 72 72 + when String.starts_with ~prefix:"git subtree" cmd -> 60 73 Some "Run 'monopam status' to check repository state." 61 74 | Git_error _ -> None 62 75 | Dirty_state _ -> 63 63 - Some "Commit changes in the monorepo first: cd mono && git add -A && git commit" 76 76 + Some 77 77 + "Commit changes in the monorepo first: cd mono && git add -A && git \ 78 78 + commit" 79 79 + | Monorepo_dirty -> 80 80 + Some "Commit or stash your changes first: git status && git add -A && git commit" 64 81 | Package_not_found _ -> 65 82 Some "Check available packages: ls opam-repo/packages/" 66 83 | Claude_error msg when String.starts_with ~prefix:"Failed to decode" msg -> ··· 132 149 (fun pkg -> 133 150 let repo = Package.repo_name pkg in 134 151 let name = Package.name pkg in 135 135 - let existing = try Hashtbl.find registered_by_repo repo with Not_found -> [] in 152 152 + let existing = 153 153 + try Hashtbl.find registered_by_repo repo with Not_found -> [] 154 154 + in 136 155 Hashtbl.replace registered_by_repo repo (name :: existing)) 137 156 pkgs; 138 157 (* Get unique subtree directories *) ··· 154 173 let repo = Package.repo_name pkg in 155 174 let subtree_dir = Fpath.(monorepo / Package.subtree_prefix pkg) in 156 175 let eio_path = Eio.Path.(fs / Fpath.to_string subtree_dir) in 157 157 - let registered = try Hashtbl.find registered_by_repo repo with Not_found -> [] in 176 176 + let registered = 177 177 + try Hashtbl.find registered_by_repo repo with Not_found -> [] 178 178 + in 158 179 try 159 180 Eio.Path.read_dir eio_path 160 181 |> List.filter_map (fun name -> ··· 166 187 with Eio.Io _ -> []) 167 188 repos 168 189 190 190 + (** Information about a package discovered from the monorepo. *) 191 191 + type monorepo_package = { 192 192 + pkg_name : string; 193 193 + subtree : string; 194 194 + dev_repo : string; 195 195 + url_src : string; 196 196 + opam_content : string; 197 197 + } 198 198 + 199 199 + (** Discover packages from monorepo subtrees by parsing dune-project files. 200 200 + If [sources] is provided, it overrides the dev-repo URL for matching subtrees. *) 201 201 + let discover_packages_from_monorepo ~fs ~config ?(sources = Sources_registry.empty) () = 202 202 + let fs = fs_typed fs in 203 203 + let monorepo = Config.Paths.monorepo config in 204 204 + let monorepo_eio = Eio.Path.(fs / Fpath.to_string monorepo) in 205 205 + 206 206 + (* List all subdirectories of monorepo *) 207 207 + let subdirs = 208 208 + try 209 209 + Eio.Path.read_dir monorepo_eio 210 210 + |> List.filter (fun name -> 211 211 + let child = Eio.Path.(monorepo_eio / name) in 212 212 + match Eio.Path.kind ~follow:false child with 213 213 + | `Directory -> true 214 214 + | _ -> false) 215 215 + with Eio.Io _ -> [] 216 216 + in 217 217 + 218 218 + Log.debug (fun m -> m "Found %d subdirectories in monorepo" (List.length subdirs)); 219 219 + 220 220 + (* Process each subdirectory *) 221 221 + let packages, errors = 222 222 + List.fold_left 223 223 + (fun (pkgs, errs) subtree -> 224 224 + let subtree_path = Eio.Path.(monorepo_eio / subtree) in 225 225 + let dune_project_path = Eio.Path.(subtree_path / "dune-project") in 226 226 + 227 227 + (* Check if dune-project exists *) 228 228 + match Eio.Path.kind ~follow:false dune_project_path with 229 229 + | `Regular_file -> ( 230 230 + (* Parse dune-project *) 231 231 + let content = 232 232 + try Some (Eio.Path.load dune_project_path) 233 233 + with Eio.Io _ -> None 234 234 + in 235 235 + match content with 236 236 + | None -> (pkgs, errs) 237 237 + | Some content -> ( 238 238 + match Dune_project.parse content with 239 239 + | Error msg -> 240 240 + Log.warn (fun m -> 241 241 + m "Failed to parse %s/dune-project: %s" subtree msg); 242 242 + (pkgs, msg :: errs) 243 243 + | Ok dune_proj -> ( 244 244 + (* Find all .opam files in subtree first - we need them for opam-repo fallback *) 245 245 + let opam_files = 246 246 + try 247 247 + Eio.Path.read_dir subtree_path 248 248 + |> List.filter (fun name -> 249 249 + Filename.check_suffix name ".opam") 250 250 + with Eio.Io _ -> [] 251 251 + in 252 252 + 253 253 + (* URL resolution order: 254 254 + 1. Explicit sources.toml entry for this subtree 255 255 + 2. dune-project source/homepage 256 256 + 3. sources.toml default_url_base + subtree name *) 257 257 + let sources_override = Sources_registry.find sources ~subtree in 258 258 + 259 259 + let derive_from_dune () = 260 260 + match 261 261 + ( Dune_project.dev_repo_url dune_proj, 262 262 + Dune_project.url_with_branch dune_proj ) 263 263 + with 264 264 + | Ok dev_repo, Ok url_src -> Some (dev_repo, url_src) 265 265 + | Error _, _ | _, Error _ -> None 266 266 + in 267 267 + 268 268 + let derive_from_default_base () = 269 269 + (* Use default_url_base from sources.toml to construct URL *) 270 270 + match Sources_registry.derive_url sources ~subtree with 271 271 + | Some dev_repo -> 272 272 + Log.debug (fun m -> 273 273 + m "Using default_url_base for %s: %s" subtree dev_repo); 274 274 + Some (dev_repo, dev_repo ^ "#main") 275 275 + | None -> None 276 276 + in 277 277 + 278 278 + let dev_repo_and_url = 279 279 + match sources_override with 280 280 + | Some entry -> 281 281 + (* Use explicit sources.toml entry *) 282 282 + let dev_repo = entry.Sources_registry.url in 283 283 + let branch = 284 284 + match entry.Sources_registry.branch with 285 285 + | Some b -> b 286 286 + | None -> ( 287 287 + (* Try to get branch from dune-project, default to main *) 288 288 + match dune_proj.source with 289 289 + | Some (Dune_project.Uri { branch = Some b; _ }) -> b 290 290 + | _ -> "main") 291 291 + in 292 292 + Log.debug (fun m -> 293 293 + m "Using sources.toml entry for %s: %s" subtree dev_repo); 294 294 + Some (dev_repo, dev_repo ^ "#" ^ branch) 295 295 + | None -> ( 296 296 + match derive_from_dune () with 297 297 + | Some result -> Some result 298 298 + | None -> ( 299 299 + match derive_from_default_base () with 300 300 + | Some result -> Some result 301 301 + | None -> 302 302 + Log.warn (fun m -> 303 303 + m "Cannot derive dev-repo for %s (no source in dune-project or sources.toml)" subtree); 304 304 + None)) 305 305 + in 306 306 + match dev_repo_and_url with 307 307 + | None -> (pkgs, "Cannot derive dev-repo" :: errs) 308 308 + | Some (dev_repo, url_src) -> 309 309 + Log.debug (fun m -> 310 310 + m "Found %d opam files in %s" (List.length opam_files) 311 311 + subtree); 312 312 + (* Transform each opam file *) 313 313 + let new_pkgs = 314 314 + List.filter_map 315 315 + (fun opam_file -> 316 316 + let pkg_name = 317 317 + Filename.chop_suffix opam_file ".opam" 318 318 + in 319 319 + let opam_path = 320 320 + Eio.Path.(subtree_path / opam_file) 321 321 + in 322 322 + try 323 323 + let raw_content = Eio.Path.load opam_path in 324 324 + let opam_content = 325 325 + Opam_transform.transform ~content:raw_content 326 326 + ~dev_repo ~url_src 327 327 + in 328 328 + Some 329 329 + { pkg_name; subtree; dev_repo; url_src; opam_content } 330 330 + with Eio.Io _ -> None) 331 331 + opam_files 332 332 + in 333 333 + (new_pkgs @ pkgs, errs)))) 334 334 + | _ -> 335 335 + (* No dune-project, skip *) 336 336 + Log.debug (fun m -> m "No dune-project in %s, skipping" subtree); 337 337 + (pkgs, errs) 338 338 + | exception Eio.Io _ -> 339 339 + (pkgs, errs)) 340 340 + ([], []) subdirs 341 341 + in 342 342 + 343 343 + if errors <> [] then 344 344 + Log.warn (fun m -> 345 345 + m "Encountered %d errors during monorepo discovery" (List.length errors)); 346 346 + 347 347 + Log.info (fun m -> 348 348 + m "Discovered %d packages from monorepo" (List.length packages)); 349 349 + Ok (List.rev packages) 350 350 + 169 351 let get_branch ~config pkg = 170 170 - let default = Config.default_branch config in 352 352 + let default = Config.default_branch in 171 353 match Package.branch pkg with 172 354 | Some b -> b 173 355 | None -> ··· 241 423 else dev_repo 242 424 in 243 425 let repo_cell = 244 244 - if i = 0 then Printf.sprintf "[**%s**](%s)" repo display_url 245 245 - else "" 426 426 + if i = 0 then Printf.sprintf "[**%s**](%s)" repo display_url else "" 246 427 in 247 428 let synopsis = Option.value ~default:"" (Package.synopsis pkg) in 248 429 Buffer.add_string buf 249 249 - (Printf.sprintf "| %s | %s | %s |\n" repo_cell 250 250 - (Package.name pkg) synopsis)) 430 430 + (Printf.sprintf "| %s | %s | %s |\n" repo_cell (Package.name pkg) 431 431 + synopsis)) 251 432 pkgs) 252 433 grouped; 253 434 Buffer.add_string buf "\n---\n\n"; ··· 366 547 (** Collect all external dependencies by scanning monorepo subtree directories. 367 548 This scans all .opam files in each subtree directory to find dependencies, 368 549 ensuring we get dependencies from all packages in a directory, not just 369 369 - those registered in the opam overlay. 370 370 - Returns a sorted, deduplicated list of package names that are dependencies 371 371 - but not packages in the repo itself. *) 550 550 + those registered in the opam overlay. Returns a sorted, deduplicated list of 551 551 + package names that are dependencies but not packages in the repo itself. *) 372 552 let collect_external_deps ~fs ~config pkgs = 373 553 let monorepo = Config.Paths.monorepo config in 374 554 (* Get unique repos to avoid scanning the same directory multiple times *) ··· 412 592 (* Filter out packages that are in the repo *) 413 593 List.filter (fun dep -> not (List.mem dep pkg_names)) all_deps 414 594 415 415 - (** Generate dune-project content for the monorepo root. 416 416 - Lists all external dependencies as a virtual package. *) 595 595 + (** Generate dune-project content for the monorepo root. Lists all external 596 596 + dependencies as a virtual package. *) 417 597 let generate_dune_project ~fs ~config pkgs = 418 598 let external_deps = collect_external_deps ~fs ~config pkgs in 419 599 let buf = Buffer.create 1024 in ··· 459 639 Eio.Switch.run (fun sw -> 460 640 let child = 461 641 Eio.Process.spawn proc ~sw ~cwd:monorepo_eio 462 462 - [ "git"; "commit"; "-m"; "Update dune-project with external dependencies" ] 642 642 + [ 643 643 + "git"; 644 644 + "commit"; 645 645 + "-m"; 646 646 + "Update dune-project with external dependencies"; 647 647 + ] 463 648 in 464 649 ignore (Eio.Process.await child)); 465 650 Log.app (fun m -> ··· 613 798 Log.app (fun m -> m "Updated CLAUDE.md") 614 799 end 615 800 801 801 + (** Check if a host is a tangled server *) 802 802 + let is_tangled_host = function 803 803 + | Some "tangled.org" | Some "tangled.sh" -> true 804 804 + | _ -> false 805 805 + 616 806 (** Convert a clone URL to a push URL. 617 807 - GitHub HTTPS URLs are converted to SSH format 618 618 - - Tangled URLs (tangled.org) are converted to git.recoil.org SSH format 619 619 - - Other URLs are returned unchanged *) 620 620 - let url_to_push_url uri = 808 808 + - Tangled URLs (tangled.org/tangled.sh) are converted to SSH format using the knot server 809 809 + - Other URLs are returned unchanged 810 810 + @param knot Git push server hostname. Defaults to git.recoil.org if not provided. *) 811 811 + let url_to_push_url ?knot uri = 621 812 let scheme = Uri.scheme uri in 622 813 let host = Uri.host uri in 623 814 let path = Uri.path uri in 624 815 match (scheme, host) with 625 816 | Some ("https" | "http"), Some "github.com" -> 626 817 (* https://github.com/user/repo.git -> git@github.com:user/repo.git *) 627 627 - let path = if String.length path > 0 && path.[0] = '/' then 628 628 - String.sub path 1 (String.length path - 1) 629 629 - else path in 818 818 + let path = 819 819 + if String.length path > 0 && path.[0] = '/' then 820 820 + String.sub path 1 (String.length path - 1) 821 821 + else path 822 822 + in 630 823 Printf.sprintf "git@github.com:%s" path 631 631 - | Some ("https" | "http"), Some "tangled.org" -> 632 632 - (* https://tangled.org/@anil.recoil.org/foo -> git@git.recoil.org:anil.recoil.org/foo *) 633 633 - let path = if String.length path > 0 && path.[0] = '/' then 634 634 - String.sub path 1 (String.length path - 1) 635 635 - else path in 636 636 - (* Strip leading @ from username if present *) 637 637 - let path = if String.length path > 0 && path.[0] = '@' then 638 638 - String.sub path 1 (String.length path - 1) 639 639 - else path in 824 824 + | Some ("https" | "http"), _ when is_tangled_host host -> 825 825 + (* https://tangled.org/@handle/repo -> git@<knot>:handle/repo *) 826 826 + let path = 827 827 + if String.length path > 0 && path.[0] = '/' then 828 828 + String.sub path 1 (String.length path - 1) 829 829 + else path 830 830 + in 831 831 + (* Strip leading @ from handle if present *) 832 832 + let path = 833 833 + if String.length path > 0 && path.[0] = '@' then 834 834 + String.sub path 1 (String.length path - 1) 835 835 + else path 836 836 + in 640 837 (* Strip .git suffix if present *) 641 641 - let path = if String.ends_with ~suffix:".git" path then 642 642 - String.sub path 0 (String.length path - 4) 643 643 - else path in 644 644 - Printf.sprintf "git@git.recoil.org:%s" path 838 838 + let path = 839 839 + if String.ends_with ~suffix:".git" path then 840 840 + String.sub path 0 (String.length path - 4) 841 841 + else path 842 842 + in 843 843 + (* Use provided knot or default to git.recoil.org *) 844 844 + let knot_server = Option.value ~default:"git.recoil.org" knot in 845 845 + Printf.sprintf "git@%s:%s" knot_server path 645 846 | _ -> 646 847 (* Return original URL for other cases *) 647 848 Uri.to_string uri ··· 689 890 let pull_subtree ~proc ~fs ~config pkg = 690 891 let fs = fs_typed fs in 691 892 let monorepo = Config.Paths.monorepo config in 893 893 + let checkouts_root = Config.Paths.checkouts config in 692 894 let prefix = Package.subtree_prefix pkg in 693 895 let branch = get_branch ~config pkg in 694 694 - let url = Package.dev_repo pkg in 896 896 + (* Pull from local checkout, not remote URL - ensures push/pull use same source *) 897 897 + let checkout_dir = Package.checkout_dir ~checkouts_root pkg in 898 898 + let url = Uri.of_string (Fpath.to_string checkout_dir) in 695 899 if Git.Subtree.exists ~fs ~repo:monorepo ~prefix then begin 696 696 - Log.info (fun m -> m "Pulling subtree %s" prefix); 900 900 + Log.info (fun m -> m "Pulling subtree %s from %a" prefix Fpath.pp checkout_dir); 697 901 match Git.Subtree.pull ~proc ~fs ~repo:monorepo ~prefix ~url ~branch () with 698 902 | Ok () -> Ok false (* not newly added *) 699 903 | Error e -> Error (Git_error e) 700 904 end 701 905 else begin 702 702 - Log.info (fun m -> m "Adding subtree %s" prefix); 906 906 + Log.info (fun m -> m "Adding subtree %s from %a" prefix Fpath.pp checkout_dir); 703 907 match Git.Subtree.add ~proc ~fs ~repo:monorepo ~prefix ~url ~branch () with 704 908 | Ok () -> Ok true (* newly added *) 705 909 | Error e -> Error (Git_error e) ··· 743 947 else begin 744 948 (* Opam repo doesn't exist - clone it if we have a URL *) 745 949 match opam_repo_url with 746 746 - | Some url -> 747 747 - Log.info (fun m -> m "Cloning opam repo from %s to %a" url Fpath.pp opam_repo); 950 950 + | Some url -> ( 951 951 + Log.info (fun m -> 952 952 + m "Cloning opam repo from %s to %a" url Fpath.pp opam_repo); 748 953 let url = Uri.of_string url in 749 749 - let branch = Config.default_branch config in 750 750 - (match Git.clone ~proc ~fs:fs_t ~url ~branch opam_repo with 954 954 + let branch = Config.default_branch in 955 955 + match Git.clone ~proc ~fs:fs_t ~url ~branch opam_repo with 751 956 | Ok () -> Log.info (fun m -> m "Opam repo cloned successfully") 752 752 - | Error e -> Log.warn (fun m -> m "Failed to clone opam repo: %a" Git.pp_error e)) 957 957 + | Error e -> 958 958 + Log.warn (fun m -> m "Failed to clone opam repo: %a" Git.pp_error e) 959 959 + ) 753 960 | None -> 754 754 - Log.info (fun m -> m "Opam repo at %a does not exist and no URL provided" Fpath.pp opam_repo) 961 961 + Log.info (fun m -> 962 962 + m "Opam repo at %a does not exist and no URL provided" Fpath.pp 963 963 + opam_repo) 755 964 end; 756 965 (* Ensure directories exist before computing status *) 757 966 ensure_checkouts_dir ~fs:fs_t ~config; ··· 893 1102 end 894 1103 end) 895 1104 896 896 - let run_git_in ~proc ~cwd args = 897 897 - Eio.Switch.run @@ fun sw -> 898 898 - let buf_stdout = Buffer.create 256 in 899 899 - let buf_stderr = Buffer.create 256 in 900 900 - let child = 901 901 - Eio.Process.spawn proc ~sw ~cwd 902 902 - ~stdout:(Eio.Flow.buffer_sink buf_stdout) 903 903 - ~stderr:(Eio.Flow.buffer_sink buf_stderr) 904 904 - ("git" :: args) 905 905 - in 906 906 - match Eio.Process.await child with 907 907 - | `Exited 0 -> Ok (Buffer.contents buf_stdout |> String.trim) 908 908 - | _ -> 909 909 - let result = 910 910 - Git. 911 911 - { 912 912 - exit_code = 1; 913 913 - stdout = Buffer.contents buf_stdout; 914 914 - stderr = Buffer.contents buf_stderr; 915 915 - } 916 916 - in 917 917 - Error (Git.Command_failed (String.concat " " ("git" :: args), result)) 918 918 - 919 1105 let push_one ~proc ~fs ~config pkg = 920 1106 let ( let* ) r f = 921 1107 Result.bind (Result.map_error (fun e -> Git_error e) r) f ··· 926 1112 let checkouts_root = Config.Paths.checkouts config in 927 1113 let checkout_dir = Package.checkout_dir ~checkouts_root pkg in 928 1114 let branch = get_branch ~config pkg in 929 929 - let sync_branch = "monopam-sync" in 930 1115 if not (Git.Subtree.exists ~fs ~repo:monorepo ~prefix) then begin 931 1116 Log.debug (fun m -> m "Subtree %s not in monorepo, skipping" prefix); 932 1117 Ok () ··· 941 1126 in 942 1127 let* () = 943 1128 if needs_clone then begin 944 944 - Log.info (fun m -> 945 945 - m "Creating checkout for %s" (Package.repo_name pkg)); 1129 1129 + Log.info (fun m -> m "Creating checkout for %s" (Package.repo_name pkg)); 946 1130 ensure_checkout ~proc ~fs:(fs :> _ Eio.Path.t) ~config pkg 947 1131 end 948 1132 else Ok () 949 1133 in 950 950 - let monorepo_eio = Eio.Path.(fs / Fpath.to_string monorepo) in 951 951 - let checkout_path = Fpath.to_string checkout_dir in 952 952 - (* Push subtree to a sync branch (avoids "branch is checked out" error) *) 953 953 - Log.info (fun m -> m "Pushing subtree %s to checkout" prefix); 954 954 - let* _ = 955 955 - run_git_in ~proc ~cwd:monorepo_eio 956 956 - [ 957 957 - "subtree"; "push"; "--prefix"; prefix; checkout_path; sync_branch; 958 958 - ] 959 959 - in 960 960 - (* Merge sync branch into the target branch in checkout *) 961 961 - Log.debug (fun m -> m "Merging %s into %s" sync_branch branch); 962 962 - let* _ = 963 963 - run_git_in ~proc ~cwd:checkout_eio 964 964 - [ "merge"; "--ff-only"; sync_branch ] 965 965 - in 966 966 - (* Delete the sync branch *) 967 967 - Log.debug (fun m -> m "Cleaning up %s branch" sync_branch); 968 968 - ignore 969 969 - (run_git_in ~proc ~cwd:checkout_eio [ "branch"; "-d"; sync_branch ]); 1134 1134 + (* Use git subtree push to export commits to the checkout. 1135 1135 + This preserves commit identity, ensuring round-trips converge. *) 1136 1136 + let checkout_url = Uri.of_string (Fpath.to_string checkout_dir) in 1137 1137 + Log.info (fun m -> m "Subtree push %s -> %a" prefix Fpath.pp checkout_dir); 1138 1138 + let* () = Git.Subtree.push ~proc ~fs ~repo:monorepo ~prefix ~url:checkout_url ~branch () in 970 1139 Ok () 971 1140 end 972 1141 ··· 1012 1181 | Ok pushed_repos -> 1013 1182 if upstream && pushed_repos <> [] then begin 1014 1183 Log.info (fun m -> 1015 1015 - m "Pushing %d repos to upstream" (List.length pushed_repos)); 1184 1184 + m "Pushing %d repos to upstream (parallel)" 1185 1185 + (List.length pushed_repos)); 1016 1186 let checkouts_root = Config.Paths.checkouts config in 1017 1017 - let total = List.length pushed_repos in 1018 1018 - let rec push_upstream i = function 1019 1019 - | [] -> Ok () 1020 1020 - | pkg :: rest -> ( 1187 1187 + (* Push to remotes in parallel, limited to 2 concurrent pushes *) 1188 1188 + let push_results = 1189 1189 + Eio.Fiber.List.map ~max_fibers:2 1190 1190 + (fun pkg -> 1021 1191 let checkout_dir = 1022 1192 Package.checkout_dir ~checkouts_root pkg 1023 1193 in 1024 1194 let branch = get_branch ~config pkg in 1025 1025 - (* Configure push URL (rewriting GitHub/tangled URLs to SSH) *) 1026 1195 let push_url = url_to_push_url (Package.dev_repo pkg) in 1027 1196 Log.info (fun m -> 1028 1028 - m "[%d/%d] Pushing %s to %s" i total 1029 1029 - (Package.repo_name pkg) push_url); 1197 1197 + m "Pushing %s to %s" (Package.repo_name pkg) push_url); 1030 1198 (* Set the push URL for origin *) 1031 1031 - (match Git.set_push_url ~proc ~fs:fs_t ~url:push_url checkout_dir with 1032 1032 - | Ok () -> () 1033 1033 - | Error e -> 1034 1034 - Log.warn (fun m -> 1035 1035 - m "Failed to set push URL: %a" Git.pp_error e)); 1199 1199 + (match 1200 1200 + Git.set_push_url ~proc ~fs:fs_t ~url:push_url 1201 1201 + checkout_dir 1202 1202 + with 1203 1203 + | Ok () -> () 1204 1204 + | Error e -> 1205 1205 + Log.warn (fun m -> 1206 1206 + m "Failed to set push URL: %a" Git.pp_error e)); 1036 1207 match 1037 1208 Git.push_remote ~proc ~fs:fs_t ~branch checkout_dir 1038 1209 with ··· 1040 1211 Log.app (fun m -> 1041 1212 m " Pushed %s to %s (%s)" (Package.repo_name pkg) 1042 1213 push_url branch); 1043 1043 - push_upstream (i + 1) rest 1214 1214 + Ok () 1044 1215 | Error e -> Error (Git_error e)) 1216 1216 + pushed_repos 1045 1217 in 1046 1046 - push_upstream 1 pushed_repos 1218 1218 + (* Return first error if any *) 1219 1219 + match List.find_opt Result.is_error push_results with 1220 1220 + | Some (Error e) -> Error e 1221 1221 + | _ -> Ok () 1047 1222 end 1048 1223 else Ok () 1049 1224 end ··· 1074 1249 | `Push_remote -> Fmt.string ppf "push-remote" 1075 1250 1076 1251 let pp_sync_failure ppf f = 1077 1077 - Fmt.pf ppf "%s (%a): %a" f.repo_name pp_sync_phase f.phase Git.pp_error f.error 1252 1252 + Fmt.pf ppf "%s (%a): %a" f.repo_name pp_sync_phase f.phase Git.pp_error 1253 1253 + f.error 1078 1254 1079 1255 let pp_sync_summary ppf s = 1080 1256 Fmt.pf ppf "Synced: %d, Unchanged: %d, Pulled: %d commits, Pushed: %d commits" 1081 1257 s.repos_synced s.repos_unchanged s.commits_pulled s.commits_pushed; 1082 1258 if s.errors <> [] then 1083 1083 - Fmt.pf ppf "@.Errors (%d):@. @[<v>%a@]" 1084 1084 - (List.length s.errors) 1085 1085 - Fmt.(list ~sep:cut pp_sync_failure) s.errors 1259 1259 + Fmt.pf ppf "@.Errors (%d):@. @[<v>%a@]" (List.length s.errors) 1260 1260 + Fmt.(list ~sep:cut pp_sync_failure) 1261 1261 + s.errors 1086 1262 1087 1263 (* Helper to ensure checkout exists, returning whether it was cloned *) 1088 1264 let ensure_checkout_safe ~proc ~fs ~config pkg = ··· 1101 1277 Log.info (fun m -> 1102 1278 m "Cloning %s from %a (branch: %s)" (Package.repo_name pkg) Uri.pp 1103 1279 (Package.dev_repo pkg) branch); 1104 1104 - match Git.clone ~proc ~fs ~url:(Package.dev_repo pkg) ~branch checkout_dir with 1105 1105 - | Ok () -> Ok (true, 0) 1280 1280 + match 1281 1281 + Git.clone ~proc ~fs ~url:(Package.dev_repo pkg) ~branch checkout_dir 1282 1282 + with 1283 1283 + | Ok () -> 1284 1284 + (* Configure checkout to accept pushes to current branch. 1285 1285 + This allows pushing from monorepo subtrees to the checkout. *) 1286 1286 + let cwd = Eio.Path.(fs / Fpath.to_string checkout_dir) in 1287 1287 + Eio.Switch.run (fun sw -> 1288 1288 + let child = 1289 1289 + Eio.Process.spawn proc ~sw ~cwd 1290 1290 + [ "git"; "config"; "receive.denyCurrentBranch"; "updateInstead" ] 1291 1291 + in 1292 1292 + ignore (Eio.Process.await child)); 1293 1293 + Ok (true, 0) 1106 1294 | Error e -> Error e 1107 1295 end 1108 1108 - else Ok (false, 0) 1296 1296 + else begin 1297 1297 + (* Ensure existing checkout is configured to accept pushes *) 1298 1298 + let cwd = Eio.Path.(fs / Fpath.to_string checkout_dir) in 1299 1299 + Eio.Switch.run (fun sw -> 1300 1300 + let child = 1301 1301 + Eio.Process.spawn proc ~sw ~cwd 1302 1302 + [ "git"; "config"; "receive.denyCurrentBranch"; "updateInstead" ] 1303 1303 + in 1304 1304 + ignore (Eio.Process.await child)); 1305 1305 + Ok (false, 0) 1306 1306 + end 1109 1307 1110 1308 (* Fetch a single checkout - safe for parallel execution *) 1111 1309 let fetch_checkout_safe ~proc ~fs ~config pkg = ··· 1147 1345 Log.info (fun m -> m "Pushing %s to %s" (Package.repo_name pkg) push_url); 1148 1346 (* Set the push URL for origin *) 1149 1347 (match Git.set_push_url ~proc ~fs ~url:push_url checkout_dir with 1150 1150 - | Ok () -> () 1151 1151 - | Error e -> 1152 1152 - Log.warn (fun m -> m "Failed to set push URL: %a" Git.pp_error e)); 1348 1348 + | Ok () -> () 1349 1349 + | Error e -> Log.warn (fun m -> m "Failed to set push URL: %a" Git.pp_error e)); 1153 1350 Git.push_remote ~proc ~fs ~branch checkout_dir 1154 1351 1155 1352 (* Sanitize handle for use as git remote name *) 1156 1353 let sanitize_remote_name handle = 1157 1354 (* Replace @ and . with - for valid git remote names *) 1158 1158 - String.map (function 1159 1159 - | '@' | '.' -> '-' 1160 1160 - | c -> c) handle 1355 1355 + String.map (function '@' | '.' -> '-' | c -> c) handle 1161 1356 1162 1357 (* Ensure verse remotes for a single repo *) 1163 1358 let ensure_verse_remotes_for_repo ~proc ~fs ~config ~verse_subtrees pkg = ··· 1170 1365 else begin 1171 1366 (* Get all verse members who have this repo *) 1172 1367 let members_with_repo = 1173 1173 - Hashtbl.find_opt verse_subtrees repo_name 1174 1174 - |> Option.value ~default:[] 1368 1368 + Hashtbl.find_opt verse_subtrees repo_name |> Option.value ~default:[] 1175 1369 in 1176 1370 1177 1371 (* Get current remotes *) 1178 1372 let current_remotes = Git.list_remotes ~proc ~fs checkout_dir in 1179 1373 let verse_remotes = 1180 1180 - List.filter (fun r -> String.starts_with ~prefix:"verse-" r) current_remotes 1374 1374 + List.filter 1375 1375 + (fun r -> String.starts_with ~prefix:"verse-" r) 1376 1376 + current_remotes 1181 1377 in 1182 1378 1183 1379 (* Build set of expected verse remotes *) 1184 1380 let expected_remotes = 1185 1185 - List.map (fun (handle, _) -> "verse-" ^ sanitize_remote_name handle) members_with_repo 1381 1381 + List.map 1382 1382 + (fun (handle, _) -> "verse-" ^ sanitize_remote_name handle) 1383 1383 + members_with_repo 1186 1384 in 1187 1385 1188 1386 (* Add/update remotes for verse members *) 1189 1189 - List.iter (fun (handle, verse_mono_path) -> 1387 1387 + List.iter 1388 1388 + (fun (handle, verse_mono_path) -> 1190 1389 let remote_name = "verse-" ^ sanitize_remote_name handle in 1191 1390 (* Point to their src/ checkout for this repo *) 1192 1391 let verse_src = Fpath.(parent verse_mono_path / "src" / repo_name) in 1193 1392 if Sys.file_exists (Fpath.to_string verse_src) then begin 1194 1393 let url = Fpath.to_string verse_src in 1195 1195 - match Git.ensure_remote ~proc ~fs ~name:remote_name ~url checkout_dir with 1196 1196 - | Ok () -> Log.debug (fun m -> m "Ensured verse remote %s -> %s" remote_name url) 1197 1197 - | Error e -> Log.warn (fun m -> m "Failed to add verse remote %s: %a" remote_name Git.pp_error e) 1394 1394 + match 1395 1395 + Git.ensure_remote ~proc ~fs ~name:remote_name ~url checkout_dir 1396 1396 + with 1397 1397 + | Ok () -> 1398 1398 + Log.debug (fun m -> 1399 1399 + m "Ensured verse remote %s -> %s" remote_name url) 1400 1400 + | Error e -> 1401 1401 + Log.warn (fun m -> 1402 1402 + m "Failed to add verse remote %s: %a" remote_name Git.pp_error 1403 1403 + e) 1198 1404 end) 1199 1405 members_with_repo; 1200 1406 1201 1407 (* Remove outdated verse remotes *) 1202 1202 - List.iter (fun remote_name -> 1408 1408 + List.iter 1409 1409 + (fun remote_name -> 1203 1410 if not (List.mem remote_name expected_remotes) then begin 1204 1411 Log.debug (fun m -> m "Removing outdated verse remote %s" remote_name); 1205 1412 match Git.remove_remote ~proc ~fs ~name:remote_name checkout_dir with 1206 1413 | Ok () -> () 1207 1207 - | Error e -> Log.warn (fun m -> m "Failed to remove verse remote %s: %a" remote_name Git.pp_error e) 1414 1414 + | Error e -> 1415 1415 + Log.warn (fun m -> 1416 1416 + m "Failed to remove verse remote %s: %a" remote_name 1417 1417 + Git.pp_error e) 1208 1418 end) 1209 1419 verse_remotes 1210 1420 end ··· 1212 1422 (* Sync verse remotes for all repos *) 1213 1423 let sync_verse_remotes ~proc ~fs ~config ~verse_config repos = 1214 1424 Log.app (fun m -> m " Updating verse remotes..."); 1215 1215 - let verse_subtrees = Verse.get_verse_subtrees ~proc ~fs ~config:verse_config () in 1216 1216 - List.iter (fun pkg -> 1425 1425 + let verse_subtrees = 1426 1426 + Verse.get_verse_subtrees ~proc ~fs ~config:verse_config () 1427 1427 + in 1428 1428 + List.iter 1429 1429 + (fun pkg -> 1217 1430 ensure_verse_remotes_for_repo ~proc ~fs ~config ~verse_subtrees pkg) 1218 1431 repos 1219 1432 ··· 1221 1434 let fetch_verse_remotes ~proc ~fs ~config pkg = 1222 1435 let checkouts_root = Config.Paths.checkouts config in 1223 1436 let checkout_dir = Package.checkout_dir ~checkouts_root pkg in 1224 1224 - (* Skip packages without checkouts *) 1225 1225 - if not (Git.is_repo ~proc ~fs checkout_dir) then 1226 1226 - Log.info (fun m -> m "Skipping verse fetch for %s (no checkout)" (Package.repo_name pkg)) 1227 1227 - else begin 1228 1228 - let remotes = Git.list_remotes ~proc ~fs checkout_dir in 1229 1229 - let verse_remotes = List.filter (fun r -> String.starts_with ~prefix:"verse-" r) remotes in 1230 1230 - List.iter (fun remote -> 1231 1231 - Log.debug (fun m -> m "Fetching from verse remote %s" remote); 1232 1232 - match Git.fetch ~proc ~fs ~remote checkout_dir with 1233 1233 - | Ok () -> () 1234 1234 - | Error e -> Log.debug (fun m -> m "Failed to fetch from %s: %a" remote Git.pp_error e)) 1235 1235 - verse_remotes 1236 1236 - end 1437 1437 + let remotes = Git.list_remotes ~proc ~fs checkout_dir in 1438 1438 + let verse_remotes = 1439 1439 + List.filter (fun r -> String.starts_with ~prefix:"verse-" r) remotes 1440 1440 + in 1441 1441 + List.iter 1442 1442 + (fun remote -> 1443 1443 + Log.debug (fun m -> m "Fetching from verse remote %s" remote); 1444 1444 + match Git.fetch ~proc ~fs ~remote checkout_dir with 1445 1445 + | Ok () -> () 1446 1446 + | Error e -> 1447 1447 + Log.debug (fun m -> 1448 1448 + m "Failed to fetch from %s: %a" remote Git.pp_error e)) 1449 1449 + verse_remotes 1237 1450 1238 1238 - let sync ~proc ~fs ~config ?package ?(remote = false) ?(skip_push = false) ?(skip_pull = false) () = 1451 1451 + (* Helper to read file contents, returning None if file doesn't exist *) 1452 1452 + let read_file_opt path = try Some (Eio.Path.load path) with Eio.Io _ -> None 1453 1453 + 1454 1454 + (* Regenerate opam-repo entries from monorepo dune-project files. 1455 1455 + This ensures URLs in opam-repo match the monorepo before sync. *) 1456 1456 + let regenerate_opam_repo ~fs ~config () = 1457 1457 + let monorepo = Config.Paths.monorepo config in 1458 1458 + let sources_path = Fpath.(monorepo / "sources.toml") in 1459 1459 + let sources = 1460 1460 + match Sources_registry.load ~fs sources_path with 1461 1461 + | Ok s -> s 1462 1462 + | Error _ -> Sources_registry.empty 1463 1463 + in 1464 1464 + match discover_packages_from_monorepo ~fs ~config ~sources () with 1465 1465 + | Error _ -> () (* Skip on error *) 1466 1466 + | Ok pkgs -> 1467 1467 + let opam_repo = Config.Paths.opam_repo config in 1468 1468 + let updated = ref 0 in 1469 1469 + List.iter 1470 1470 + (fun pkg -> 1471 1471 + let pkg_dir = 1472 1472 + Fpath.(opam_repo / "packages" / pkg.pkg_name / (pkg.pkg_name ^ ".dev")) 1473 1473 + in 1474 1474 + let dst_path = Eio.Path.(fs / Fpath.to_string pkg_dir / "opam") in 1475 1475 + let dst_content = read_file_opt dst_path in 1476 1476 + if Some pkg.opam_content <> dst_content then begin 1477 1477 + let pkg_dir_eio = Eio.Path.(fs / Fpath.to_string pkg_dir) in 1478 1478 + (try Eio.Path.mkdirs ~perm:0o755 pkg_dir_eio with Eio.Io _ -> ()); 1479 1479 + Eio.Path.save ~create:(`Or_truncate 0o644) dst_path pkg.opam_content; 1480 1480 + incr updated 1481 1481 + end) 1482 1482 + pkgs; 1483 1483 + if !updated > 0 then 1484 1484 + Log.info (fun m -> m "Regenerated %d opam-repo entries from monorepo" !updated) 1485 1485 + 1486 1486 + (** Clone monorepo and opam-repo from verse registry if they don't exist locally. 1487 1487 + This enables `monopam sync` to work in a fresh devcontainer. *) 1488 1488 + let clone_from_verse_if_needed ~proc ~fs ~config () = 1489 1489 + let monorepo = Config.Paths.monorepo config in 1490 1490 + let opam_repo = Config.Paths.opam_repo config in 1491 1491 + let monorepo_exists = Git.is_repo ~proc ~fs monorepo in 1492 1492 + let opam_repo_exists = Git.is_repo ~proc ~fs opam_repo in 1493 1493 + 1494 1494 + (* If both exist, nothing to do *) 1495 1495 + if monorepo_exists && opam_repo_exists then Ok () 1496 1496 + else 1497 1497 + (* Try to load verse config to get handle *) 1498 1498 + match Verse_config.load ~fs () with 1499 1499 + | Error _ -> 1500 1500 + (* No verse config - can't clone from registry *) 1501 1501 + Log.debug (fun m -> m "No verse config found, will initialize fresh repos"); 1502 1502 + Ok () 1503 1503 + | Ok verse_config -> 1504 1504 + let handle = Verse_config.handle verse_config in 1505 1505 + Log.info (fun m -> m "Found verse config for handle: %s" handle); 1506 1506 + (* Load registry to look up URLs *) 1507 1507 + match Verse_registry.clone_or_pull ~proc ~fs ~config:verse_config () with 1508 1508 + | Error msg -> 1509 1509 + Log.warn (fun m -> m "Could not load verse registry: %s" msg); 1510 1510 + Ok () (* Continue without cloning - will init fresh *) 1511 1511 + | Ok registry -> 1512 1512 + match Verse_registry.find_member registry ~handle with 1513 1513 + | None -> 1514 1514 + Log.warn (fun m -> m "Handle %s not found in registry" handle); 1515 1515 + Ok () 1516 1516 + | Some member -> 1517 1517 + (* Clone monorepo if needed *) 1518 1518 + let result = 1519 1519 + if monorepo_exists then Ok () 1520 1520 + else begin 1521 1521 + Log.app (fun m -> m "Cloning monorepo from %s..." member.monorepo); 1522 1522 + let url = Uri.of_string member.monorepo in 1523 1523 + let branch = Option.value ~default:"main" member.monorepo_branch in 1524 1524 + match Git.clone ~proc ~fs ~url ~branch monorepo with 1525 1525 + | Ok () -> 1526 1526 + Log.app (fun m -> m "Monorepo cloned successfully"); 1527 1527 + Ok () 1528 1528 + | Error e -> 1529 1529 + Log.err (fun m -> m "Failed to clone monorepo: %a" Git.pp_error e); 1530 1530 + Error (Git_error e) 1531 1531 + end 1532 1532 + in 1533 1533 + match result with 1534 1534 + | Error e -> Error e 1535 1535 + | Ok () -> 1536 1536 + (* Clone opam-repo if needed *) 1537 1537 + if opam_repo_exists then Ok () 1538 1538 + else begin 1539 1539 + Log.app (fun m -> m "Cloning opam-repo from %s..." member.opamrepo); 1540 1540 + let url = Uri.of_string member.opamrepo in 1541 1541 + let branch = Option.value ~default:"main" member.opamrepo_branch in 1542 1542 + match Git.clone ~proc ~fs ~url ~branch opam_repo with 1543 1543 + | Ok () -> 1544 1544 + Log.app (fun m -> m "Opam-repo cloned successfully"); 1545 1545 + Ok () 1546 1546 + | Error e -> 1547 1547 + Log.err (fun m -> m "Failed to clone opam-repo: %a" Git.pp_error e); 1548 1548 + Error (Git_error e) 1549 1549 + end 1550 1550 + 1551 1551 + let sync ~proc ~fs ~config ?package ?(remote = false) ?(skip_push = false) 1552 1552 + ?(skip_pull = false) () = 1239 1553 let fs_t = fs_typed fs in 1554 1554 + 1555 1555 + (* Step 0: Sync verse members if verse config exists and not skipping pull *) 1556 1556 + (if not skip_pull then 1557 1557 + match Verse_config.load ~fs:fs_t () with 1558 1558 + | Error _ -> () (* No verse config = skip *) 1559 1559 + | Ok verse_config -> 1560 1560 + Log.app (fun m -> m "Syncing verse members..."); 1561 1561 + match Verse.pull ~proc ~fs:fs_t ~config:verse_config () with 1562 1562 + | Ok () -> () 1563 1563 + | Error e -> Log.warn (fun m -> m "Verse sync: %a" Verse.pp_error e)); 1564 1564 + 1565 1565 + (* Clone from verse registry if repos don't exist *) 1566 1566 + match clone_from_verse_if_needed ~proc ~fs:fs_t ~config () with 1567 1567 + | Error e -> Error e 1568 1568 + | Ok () -> 1569 1569 + 1240 1570 (* Update the opam repo first - clone if needed *) 1241 1571 let opam_repo = Config.Paths.opam_repo config in 1242 1572 if (not skip_pull) && Git.is_repo ~proc ~fs:fs_t opam_repo then begin ··· 1256 1586 match ensure_monorepo_initialized ~proc ~fs:fs_t ~config with 1257 1587 | Error e -> Error e 1258 1588 | Ok () -> ( 1589 1589 + (* Check for uncommitted changes in monorepo *) 1590 1590 + let monorepo = Config.Paths.monorepo config in 1591 1591 + if Git.is_dirty ~proc ~fs:fs_t monorepo then begin 1592 1592 + Log.err (fun m -> m "Monorepo has uncommitted changes"); 1593 1593 + Error Monorepo_dirty 1594 1594 + end 1595 1595 + else begin 1596 1596 + (* Regenerate opam-repo from monorepo to ensure URLs are up to date *) 1597 1597 + regenerate_opam_repo ~fs:(fs_t :> _ Eio.Path.t) ~config (); 1259 1598 match discover_packages ~fs:(fs_t :> _ Eio.Path.t) ~config () with 1260 1599 | Error e -> Error e 1261 1600 | Ok all_pkgs -> ··· 1281 1620 let total = List.length repos in 1282 1621 Log.app (fun m -> m "Syncing %d repositories..." total); 1283 1622 1623 1623 + (* Build status lookup for optimization *) 1624 1624 + let status_by_name = 1625 1625 + List.map (fun s -> (Package.name s.Status.package, s)) statuses 1626 1626 + in 1627 1627 + let sync_needs_push = function 1628 1628 + | Status.Subtree_ahead _ | Status.Trees_differ -> true 1629 1629 + | Status.In_sync | Status.Subtree_behind _ | Status.Unknown -> 1630 1630 + false 1631 1631 + in 1632 1632 + let needs_push pkg = 1633 1633 + List.assoc_opt (Package.name pkg) status_by_name 1634 1634 + |> Option.fold ~none:true ~some:(fun s -> 1635 1635 + sync_needs_push s.Status.subtree_sync) 1636 1636 + in 1637 1637 + let sync_needs_pull = function 1638 1638 + | Status.Subtree_behind _ | Status.Trees_differ -> true 1639 1639 + | Status.In_sync | Status.Subtree_ahead _ | Status.Unknown -> 1640 1640 + false 1641 1641 + in 1642 1642 + let needs_pull pkg = 1643 1643 + List.assoc_opt (Package.name pkg) status_by_name 1644 1644 + |> Option.fold ~none:true ~some:(fun s -> 1645 1645 + sync_needs_pull s.Status.subtree_sync) 1646 1646 + in 1647 1647 + 1284 1648 (* Step 2: Push phase - export monorepo changes to checkouts (PARALLEL) *) 1285 1649 (* git subtree push is read-only on the monorepo, so safe to parallelize *) 1650 1650 + (* OPTIMIZATION: skip packages already in sync *) 1286 1651 let push_results = 1287 1652 if skip_push then begin 1288 1288 - Log.app (fun m -> m " Skipping push to checkouts (--skip-push)"); 1653 1653 + Log.app (fun m -> 1654 1654 + m " Skipping push to checkouts (--skip-push)"); 1289 1655 List.map (fun pkg -> Ok (Package.repo_name pkg)) repos 1290 1656 end 1291 1657 else begin 1292 1292 - Log.app (fun m -> m " Pushing monorepo changes to checkouts (parallel)..."); 1293 1293 - Eio.Fiber.List.map ~max_fibers:12 (fun pkg -> 1294 1294 - let repo_name = Package.repo_name pkg in 1295 1295 - Log.info (fun m -> m "Push to checkout: %s" repo_name); 1296 1296 - match push_one ~proc ~fs ~config pkg with 1297 1297 - | Ok () -> Ok repo_name 1298 1298 - | Error (Git_error e) -> 1299 1299 - Error { repo_name; phase = `Push_checkout; error = e } 1300 1300 - | Error _ -> Ok repo_name) 1301 1301 - repos 1658 1658 + let to_push, to_skip = List.partition needs_push repos in 1659 1659 + Log.app (fun m -> 1660 1660 + m " Pushing monorepo changes to checkouts (parallel)..."); 1661 1661 + if to_skip <> [] then 1662 1662 + Log.app (fun m -> 1663 1663 + m " Skipping %d already-synced packages" 1664 1664 + (List.length to_skip)); 1665 1665 + (* Local git subtree push - no parallelism limit needed *) 1666 1666 + let pushed = 1667 1667 + Eio.Fiber.List.map 1668 1668 + (fun pkg -> 1669 1669 + let repo_name = Package.repo_name pkg in 1670 1670 + Log.info (fun m -> m "Push to checkout: %s" repo_name); 1671 1671 + match push_one ~proc ~fs ~config pkg with 1672 1672 + | Ok () -> Ok repo_name 1673 1673 + | Error (Git_error e) -> 1674 1674 + Error 1675 1675 + { repo_name; phase = `Push_checkout; error = e } 1676 1676 + | Error _ -> Ok repo_name) 1677 1677 + to_push 1678 1678 + in 1679 1679 + let skipped_ok = 1680 1680 + List.map (fun pkg -> Ok (Package.repo_name pkg)) to_skip 1681 1681 + in 1682 1682 + pushed @ skipped_ok 1302 1683 end 1303 1684 in 1304 1685 let push_errors = 1305 1305 - List.filter_map (function Error e -> Some e | Ok _ -> None) push_results 1686 1686 + List.filter_map 1687 1687 + (function Error e -> Some e | Ok _ -> None) 1688 1688 + push_results 1306 1689 in 1307 1690 1308 1691 (* Steps 3-5: Pull phases (fetch, merge, subtree) - skip if --skip-pull *) 1309 1309 - let fetch_errors, unchanged_count, total_commits_pulled, merge_errors, subtree_errors = 1692 1692 + let ( fetch_errors, 1693 1693 + unchanged_count, 1694 1694 + total_commits_pulled, 1695 1695 + merge_errors, 1696 1696 + subtree_errors, 1697 1697 + successfully_fetched_repos ) = 1310 1698 if skip_pull then begin 1311 1311 - Log.app (fun m -> m " Skipping pull from remotes (--skip-pull)"); 1312 1312 - ([], List.length repos, 0, ref [], ref []) 1699 1699 + Log.app (fun m -> 1700 1700 + m " Skipping pull from remotes (--skip-pull)"); 1701 1701 + ([], List.length repos, 0, ref [], ref [], repos) 1313 1702 end 1314 1703 else begin 1315 1704 (* Step 3: Fetch phase - clone/fetch from remotes (PARALLEL) *) 1316 1705 Log.app (fun m -> m " Fetching from remotes (parallel)..."); 1317 1317 - let fetch_results = Eio.Fiber.List.map ~max_fibers:3 (fun pkg -> 1318 1318 - let repo_name = Package.repo_name pkg in 1319 1319 - (* First ensure checkout exists *) 1320 1320 - match ensure_checkout_safe ~proc ~fs:fs_t ~config pkg with 1321 1321 - | Error e -> Error { repo_name; phase = `Fetch; error = e } 1322 1322 - | Ok (was_cloned, _) -> 1323 1323 - if was_cloned then Ok (repo_name, true, 0) 1324 1324 - else 1325 1325 - match fetch_checkout_safe ~proc ~fs:fs_t ~config pkg with 1326 1326 - | Error e -> Error { repo_name; phase = `Fetch; error = e } 1327 1327 - | Ok commits -> Ok (repo_name, false, commits)) 1328 1328 - repos 1706 1706 + let fetch_results = 1707 1707 + Eio.Fiber.List.map ~max_fibers:4 1708 1708 + (fun pkg -> 1709 1709 + let repo_name = Package.repo_name pkg in 1710 1710 + (* First ensure checkout exists *) 1711 1711 + match 1712 1712 + ensure_checkout_safe ~proc ~fs:fs_t ~config pkg 1713 1713 + with 1714 1714 + | Error e -> 1715 1715 + Error { repo_name; phase = `Fetch; error = e } 1716 1716 + | Ok (was_cloned, _) -> ( 1717 1717 + if was_cloned then Ok (repo_name, true, 0) 1718 1718 + else 1719 1719 + match 1720 1720 + fetch_checkout_safe ~proc ~fs:fs_t ~config pkg 1721 1721 + with 1722 1722 + | Error e -> 1723 1723 + Error { repo_name; phase = `Fetch; error = e } 1724 1724 + | Ok commits -> Ok (repo_name, false, commits))) 1725 1725 + repos 1329 1726 in 1330 1727 let fetch_errs, fetch_successes = 1331 1331 - List.partition_map (function 1332 1332 - | Error e -> Left e 1333 1333 - | Ok r -> Right r) 1728 1728 + List.partition_map 1729 1729 + (function Error e -> Left e | Ok r -> Right r) 1334 1730 fetch_results 1335 1731 in 1336 1336 - let cloned = List.filter (fun (_, c, _) -> c) fetch_successes in 1337 1337 - let updated = List.filter (fun (_, c, commits) -> not c && commits > 0) fetch_successes in 1338 1338 - let unchanged = List.length fetch_successes - List.length cloned - List.length updated in 1339 1339 - let commits_pulled = List.fold_left (fun acc (_, _, c) -> acc + c) 0 fetch_successes in 1340 1340 - Log.app (fun m -> m " Pulled: %d cloned, %d updated, %d unchanged" 1341 1341 - (List.length cloned) (List.length updated) unchanged); 1732 1732 + let cloned = 1733 1733 + List.filter (fun (_, c, _) -> c) fetch_successes 1734 1734 + in 1735 1735 + let updated = 1736 1736 + List.filter 1737 1737 + (fun (_, c, commits) -> (not c) && commits > 0) 1738 1738 + fetch_successes 1739 1739 + in 1740 1740 + let unchanged = 1741 1741 + List.length fetch_successes 1742 1742 + - List.length cloned - List.length updated 1743 1743 + in 1744 1744 + let commits_pulled = 1745 1745 + List.fold_left 1746 1746 + (fun acc (_, _, c) -> acc + c) 1747 1747 + 0 fetch_successes 1748 1748 + in 1749 1749 + Log.app (fun m -> 1750 1750 + m " Pulled: %d cloned, %d updated, %d unchanged" 1751 1751 + (List.length cloned) (List.length updated) unchanged); 1752 1752 + 1753 1753 + (* Filter repos to only those that were successfully fetched *) 1754 1754 + let success_names = 1755 1755 + List.map (fun (name, _, _) -> name) fetch_successes 1756 1756 + in 1757 1757 + let successfully_fetched = 1758 1758 + List.filter 1759 1759 + (fun pkg -> List.mem (Package.repo_name pkg) success_names) 1760 1760 + repos 1761 1761 + in 1342 1762 1343 1763 (* Step 4: Merge phase - fast-forward merge checkouts (SEQUENTIAL) *) 1344 1764 Log.app (fun m -> m " Merging checkouts..."); 1345 1765 let merge_errs = ref [] in 1346 1346 - let checkouts_root = Config.Paths.checkouts config in 1347 1347 - List.iter (fun pkg -> 1348 1348 - let checkout_dir = Package.checkout_dir ~checkouts_root pkg in 1349 1349 - (* Skip packages without checkouts *) 1350 1350 - if not (Git.is_repo ~proc ~fs:fs_t checkout_dir) then 1351 1351 - Log.info (fun m -> m "Skipping %s (no checkout)" (Package.repo_name pkg)) 1352 1352 - else 1353 1353 - match merge_checkout_safe ~proc ~fs:fs_t ~config pkg with 1354 1354 - | Ok () -> () 1355 1355 - | Error e -> 1356 1356 - merge_errs := { repo_name = Package.repo_name pkg; 1357 1357 - phase = `Merge; error = e } :: !merge_errs) 1358 1358 - repos; 1766 1766 + List.iter 1767 1767 + (fun pkg -> 1768 1768 + match merge_checkout_safe ~proc ~fs:fs_t ~config pkg with 1769 1769 + | Ok () -> () 1770 1770 + | Error e -> 1771 1771 + merge_errs := 1772 1772 + { 1773 1773 + repo_name = Package.repo_name pkg; 1774 1774 + phase = `Merge; 1775 1775 + error = e; 1776 1776 + } 1777 1777 + :: !merge_errs) 1778 1778 + successfully_fetched; 1359 1779 1360 1780 (* Step 5: Subtree phase - pull subtrees into monorepo (SEQUENTIAL) *) 1361 1781 (* Check if monorepo has local modifications first *) ··· 1364 1784 let subtree_errs = ref [] in 1365 1785 if monorepo_dirty then begin 1366 1786 Log.warn (fun m -> 1367 1367 - m "Monorepo has uncommitted changes, skipping subtree pulls"); 1368 1368 - Log.app (fun m -> m " Skipping subtree updates (local modifications)...") 1787 1787 + m 1788 1788 + "Monorepo has uncommitted changes, skipping subtree \ 1789 1789 + pulls"); 1790 1790 + Log.app (fun m -> 1791 1791 + m " Skipping subtree updates (local modifications)...") 1369 1792 end 1370 1793 else begin 1794 1794 + (* OPTIMIZATION: skip packages already in sync *) 1795 1795 + (* But always pull repos that received commits from fetch *) 1796 1796 + let repos_updated_by_fetch = 1797 1797 + List.filter_map 1798 1798 + (fun (name, was_cloned, commits) -> 1799 1799 + if was_cloned || commits > 0 then Some name else None) 1800 1800 + fetch_successes 1801 1801 + in 1802 1802 + let needs_pull_after_fetch pkg = 1803 1803 + needs_pull pkg 1804 1804 + || List.mem (Package.repo_name pkg) repos_updated_by_fetch 1805 1805 + in 1806 1806 + let to_pull, to_skip = 1807 1807 + List.partition needs_pull_after_fetch successfully_fetched 1808 1808 + in 1371 1809 Log.app (fun m -> m " Updating subtrees..."); 1372 1372 - List.iteri (fun i pkg -> 1810 1810 + if to_skip <> [] then 1811 1811 + Log.app (fun m -> 1812 1812 + m " Skipping %d already-synced subtrees" 1813 1813 + (List.length to_skip)); 1814 1814 + let pull_count = List.length to_pull in 1815 1815 + List.iteri 1816 1816 + (fun i pkg -> 1373 1817 Log.info (fun m -> 1374 1374 - m "[%d/%d] Subtree %s" (i + 1) total 1818 1818 + m "[%d/%d] Subtree %s" (i + 1) pull_count 1375 1819 (Package.subtree_prefix pkg)); 1376 1820 match pull_subtree ~proc ~fs ~config pkg with 1377 1821 | Ok _ -> () 1378 1822 | Error (Git_error e) -> 1379 1379 - subtree_errs := { repo_name = Package.repo_name pkg; 1380 1380 - phase = `Subtree; error = e } :: !subtree_errs 1823 1823 + subtree_errs := 1824 1824 + { 1825 1825 + repo_name = Package.repo_name pkg; 1826 1826 + phase = `Subtree; 1827 1827 + error = e; 1828 1828 + } 1829 1829 + :: !subtree_errs 1381 1830 | Error _ -> ()) 1382 1382 - repos 1831 1831 + to_pull 1383 1832 end; 1384 1384 - (fetch_errs, unchanged, commits_pulled, merge_errs, subtree_errs) 1833 1833 + ( fetch_errs, 1834 1834 + unchanged, 1835 1835 + commits_pulled, 1836 1836 + merge_errs, 1837 1837 + subtree_errs, 1838 1838 + successfully_fetched ) 1385 1839 end 1386 1840 in 1387 1841 1388 1842 (* Step 5.5: Verse remotes - update and fetch from verse members *) 1843 1843 + (* Only operate on successfully fetched repos to avoid missing directory errors *) 1389 1844 (match Verse_config.load ~fs:(fs_t :> _ Eio.Path.t) () with 1390 1390 - | Error _ -> () (* No verse config, skip verse remotes *) 1391 1391 - | Ok verse_config -> 1392 1392 - sync_verse_remotes ~proc ~fs:fs_t ~config ~verse_config repos; 1393 1393 - (* Fetch from verse remotes in parallel *) 1394 1394 - Log.app (fun m -> m " Fetching from verse remotes..."); 1395 1395 - Eio.Fiber.List.iter ~max_fibers:4 (fun pkg -> 1396 1396 - fetch_verse_remotes ~proc ~fs:fs_t ~config pkg) 1397 1397 - repos); 1845 1845 + | Error _ -> () (* No verse config, skip verse remotes *) 1846 1846 + | Ok verse_config -> 1847 1847 + sync_verse_remotes ~proc ~fs:fs_t ~config ~verse_config successfully_fetched_repos; 1848 1848 + (* Fetch from verse remotes in parallel *) 1849 1849 + Log.app (fun m -> m " Fetching from verse remotes..."); 1850 1850 + Eio.Fiber.List.iter ~max_fibers:4 1851 1851 + (fun pkg -> fetch_verse_remotes ~proc ~fs:fs_t ~config pkg) 1852 1852 + successfully_fetched_repos); 1398 1853 1399 1854 (* Step 6: Finalize - write README.md, CLAUDE.md, and dune-project (SEQUENTIAL) *) 1400 1400 - Log.app (fun m -> m " Writing README.md, CLAUDE.md, and dune-project..."); 1855 1855 + Log.app (fun m -> 1856 1856 + m " Writing README.md, CLAUDE.md, and dune-project..."); 1401 1857 write_readme ~proc ~fs:fs_t ~config all_pkgs; 1402 1858 write_claude_md ~proc ~fs:fs_t ~config; 1403 1859 write_dune_project ~proc ~fs:fs_t ~config all_pkgs; 1404 1860 1405 1861 (* Step 7: Remote phase - push to upstream remotes if --remote (LIMITED PARALLEL) *) 1862 1862 + (* Only push repos that were successfully fetched *) 1406 1863 let remote_errors = 1407 1864 if remote then begin 1408 1865 Log.app (fun m -> m " Pushing to upstream remotes..."); 1409 1866 (* Limit to 2 concurrent pushes to avoid overwhelming remotes *) 1410 1410 - let push_results = Eio.Fiber.List.map ~max_fibers:2 (fun pkg -> 1411 1411 - let repo_name = Package.repo_name pkg in 1412 1412 - match push_remote_safe ~proc ~fs:fs_t ~config pkg with 1413 1413 - | Error e -> Error { repo_name; phase = `Push_remote; error = e } 1414 1414 - | Ok () -> 1415 1415 - Log.app (fun m -> m " Pushed %s" repo_name); 1416 1416 - Ok repo_name) 1417 1417 - repos 1867 1867 + let push_results = 1868 1868 + Eio.Fiber.List.map ~max_fibers:2 1869 1869 + (fun pkg -> 1870 1870 + let repo_name = Package.repo_name pkg in 1871 1871 + match push_remote_safe ~proc ~fs:fs_t ~config pkg with 1872 1872 + | Error e -> 1873 1873 + Error { repo_name; phase = `Push_remote; error = e } 1874 1874 + | Ok () -> 1875 1875 + Log.app (fun m -> m " Pushed %s" repo_name); 1876 1876 + Ok repo_name) 1877 1877 + successfully_fetched_repos 1418 1878 in 1419 1879 let errors, successes = 1420 1420 - List.partition_map (function 1421 1421 - | Error e -> Left e 1422 1422 - | Ok r -> Right r) 1880 1880 + List.partition_map 1881 1881 + (function Error e -> Left e | Ok r -> Right r) 1423 1882 push_results 1424 1883 in 1425 1425 - Log.app (fun m -> m " Pushed: %d repos to upstream" (List.length successes)); 1884 1884 + Log.app (fun m -> 1885 1885 + m " Pushed: %d repos to upstream" (List.length successes)); 1426 1886 errors 1427 1887 end 1428 1888 else [] ··· 1430 1890 1431 1891 (* Collect all errors *) 1432 1892 let all_errors = 1433 1433 - push_errors @ fetch_errors @ !merge_errors @ !subtree_errors @ remote_errors 1893 1893 + push_errors @ fetch_errors @ !merge_errors @ !subtree_errors 1894 1894 + @ remote_errors 1434 1895 in 1435 1435 - let summary = { 1436 1436 - repos_synced = List.length repos - List.length all_errors; 1437 1437 - repos_unchanged = unchanged_count; 1438 1438 - commits_pulled = total_commits_pulled; 1439 1439 - commits_pushed = 0; (* TODO: track this *) 1440 1440 - errors = all_errors; 1441 1441 - } in 1896 1896 + let summary = 1897 1897 + { 1898 1898 + repos_synced = List.length repos - List.length all_errors; 1899 1899 + repos_unchanged = unchanged_count; 1900 1900 + commits_pulled = total_commits_pulled; 1901 1901 + commits_pushed = 0; 1902 1902 + (* TODO: track this *) 1903 1903 + errors = all_errors; 1904 1904 + } 1905 1905 + in 1442 1906 1443 1907 (* Print summary *) 1444 1444 - Log.app (fun m -> m "@.Summary: %d synced, %d errors" 1445 1445 - summary.repos_synced (List.length summary.errors)); 1908 1908 + Log.app (fun m -> 1909 1909 + m "@.Summary: %d synced, %d errors" summary.repos_synced 1910 1910 + (List.length summary.errors)); 1446 1911 if summary.errors <> [] then 1447 1447 - List.iter (fun e -> 1448 1448 - Log.warn (fun m -> m " %a" pp_sync_failure e)) 1912 1912 + List.iter 1913 1913 + (fun e -> Log.warn (fun m -> m " %a" pp_sync_failure e)) 1449 1914 summary.errors; 1450 1915 1451 1916 Ok summary 1452 1917 end 1453 1453 - end) 1918 1918 + end 1919 1919 + end) 1454 1920 1455 1921 (* Opam metadata sync: copy .opam files from monorepo subtrees to opam-repo *) 1456 1922 1457 1923 type opam_sync_result = { 1458 1458 - synced : string list; (* packages that were updated *) 1459 1459 - unchanged : string list; (* packages that were already in sync *) 1460 1460 - missing : string list; (* packages where monorepo has no .opam file *) 1461 1461 - orphaned : string list; (* packages in opam-repo but subtree missing from monorepo *) 1924 1924 + synced : string list; (* packages that were updated *) 1925 1925 + unchanged : string list; (* packages that were already in sync *) 1926 1926 + missing : string list; (* packages where monorepo has no .opam file *) 1927 1927 + orphaned : string list; 1928 1928 + (* packages in opam-repo but subtree missing from monorepo *) 1462 1929 } 1463 1930 1464 1931 let pp_opam_sync_result ppf r = ··· 1466 1933 (List.length r.synced) (List.length r.unchanged) (List.length r.missing) 1467 1934 (List.length r.orphaned) 1468 1935 1469 1469 - (* Read file contents safely, returning None if file doesn't exist *) 1470 1470 - let read_file_opt path = 1471 1471 - try Some (Eio.Path.load path) 1472 1472 - with Eio.Io _ -> None 1473 1473 - 1474 1474 - (* Sync a single package's opam file from monorepo to opam-repo *) 1475 1475 - let sync_opam_file ~proc ~fs ~config pkg = 1476 1476 - let monorepo = Config.Paths.monorepo config in 1936 1936 + (* List all package directories in opam-repo/packages/ *) 1937 1937 + let list_opam_repo_packages ~fs ~config = 1477 1938 let opam_repo = Config.Paths.opam_repo config in 1478 1478 - let name = Package.name pkg in 1479 1479 - let subtree_prefix = Package.subtree_prefix pkg in 1480 1480 - let version = Package.version pkg in 1939 1939 + let packages_dir = Eio.Path.(fs / Fpath.to_string opam_repo / "packages") in 1940 1940 + try 1941 1941 + Eio.Path.read_dir packages_dir 1942 1942 + |> List.filter (fun name -> 1943 1943 + let child = Eio.Path.(packages_dir / name) in 1944 1944 + match Eio.Path.kind ~follow:false child with 1945 1945 + | `Directory -> true 1946 1946 + | _ -> false) 1947 1947 + with Eio.Io _ -> [] 1481 1948 1482 1482 - (* Source: monorepo/<subtree>/<name>.opam *) 1483 1483 - let src_path = Eio.Path.(fs / Fpath.to_string monorepo / subtree_prefix / (name ^ ".opam")) in 1484 1484 - 1485 1485 - (* Destination: opam-repo/packages/<name>/<name>.<version>/opam *) 1486 1486 - let pkg_dir = Fpath.(opam_repo / "packages" / name / (name ^ "." ^ version)) in 1487 1487 - let dst_path = Eio.Path.(fs / Fpath.to_string pkg_dir / "opam") in 1488 1488 - 1489 1489 - match read_file_opt src_path with 1490 1490 - | None -> 1491 1491 - (* No opam file in monorepo subtree *) 1492 1492 - `Missing name 1493 1493 - | Some src_content -> 1494 1494 - let dst_content = read_file_opt dst_path in 1495 1495 - if Some src_content = dst_content then 1496 1496 - `Unchanged name 1497 1497 - else begin 1498 1498 - (* Create destination directory if needed *) 1499 1499 - let pkg_dir_eio = Eio.Path.(fs / Fpath.to_string pkg_dir) in 1500 1500 - (try mkdirs pkg_dir_eio with _ -> ()); 1501 1501 - (* Write the opam file *) 1502 1502 - Log.info (fun m -> m "Syncing %s.opam to opam-repo" name); 1503 1503 - Eio.Path.save ~create:(`Or_truncate 0o644) dst_path src_content; 1504 1504 - (* Stage the change *) 1505 1505 - let opam_repo_eio = Eio.Path.(fs / Fpath.to_string opam_repo) in 1506 1506 - let rel_path = Printf.sprintf "packages/%s/%s.%s/opam" name name version in 1507 1507 - Eio.Switch.run (fun sw -> 1508 1508 - let child = 1509 1509 - Eio.Process.spawn proc ~sw ~cwd:opam_repo_eio 1510 1510 - [ "git"; "add"; rel_path ] 1511 1511 - in 1512 1512 - ignore (Eio.Process.await child)); 1513 1513 - `Synced name 1514 1514 - end 1949 1949 + (* Delete a package directory from opam-repo *) 1950 1950 + let delete_opam_repo_package ~proc ~fs ~config name = 1951 1951 + let opam_repo = Config.Paths.opam_repo config in 1952 1952 + let pkg_dir = Eio.Path.(fs / Fpath.to_string opam_repo / "packages" / name) in 1953 1953 + try 1954 1954 + Eio.Path.rmtree pkg_dir; 1955 1955 + (* Stage the deletion *) 1956 1956 + let opam_repo_eio = Eio.Path.(fs / Fpath.to_string opam_repo) in 1957 1957 + let rel_path = Printf.sprintf "packages/%s" name in 1958 1958 + Eio.Switch.run (fun sw -> 1959 1959 + let child = 1960 1960 + Eio.Process.spawn proc ~sw ~cwd:opam_repo_eio 1961 1961 + [ "git"; "add"; "-A"; rel_path ] 1962 1962 + in 1963 1963 + ignore (Eio.Process.await child)); 1964 1964 + Log.info (fun m -> m "Deleted orphaned package %s from opam-repo" name); 1965 1965 + true 1966 1966 + with Eio.Io _ -> 1967 1967 + Log.warn (fun m -> m "Failed to delete package %s" name); 1968 1968 + false 1515 1969 1516 1516 - (* Sync opam files for all packages *) 1970 1970 + (* Sync opam files for all packages - generation-based approach *) 1517 1971 let sync_opam_files ~proc ~fs ~config ?package () = 1518 1972 let fs = fs_typed fs in 1519 1519 - match discover_packages ~fs:(fs :> _ Eio.Path.t) ~config () with 1973 1973 + 1974 1974 + (* Load sources.toml for URL overrides *) 1975 1975 + let monorepo = Config.Paths.monorepo config in 1976 1976 + let sources_path = Fpath.(monorepo / "sources.toml") in 1977 1977 + let sources = 1978 1978 + match Sources_registry.load ~fs:(fs :> _ Eio.Path.t) sources_path with 1979 1979 + | Ok s -> 1980 1980 + let count = List.length (Sources_registry.to_list s) in 1981 1981 + if count > 0 then 1982 1982 + Log.info (fun m -> m "Loaded %d source overrides from sources.toml" count); 1983 1983 + s 1984 1984 + | Error msg -> 1985 1985 + Log.warn (fun m -> m "Failed to load sources.toml: %s" msg); 1986 1986 + Sources_registry.empty 1987 1987 + in 1988 1988 + 1989 1989 + (* Discover packages from monorepo *) 1990 1990 + match discover_packages_from_monorepo ~fs:(fs :> _ Eio.Path.t) ~config ~sources () with 1520 1991 | Error e -> Error e 1521 1992 | Ok all_pkgs -> 1993 1993 + (* Filter to specific package/subtree if requested *) 1522 1994 let pkgs = 1523 1995 match package with 1524 1996 | None -> all_pkgs 1525 1525 - | Some name -> List.filter (fun p -> Package.name p = name) all_pkgs 1997 1997 + | Some name -> 1998 1998 + List.filter 1999 1999 + (fun p -> p.pkg_name = name || p.subtree = name) 2000 2000 + all_pkgs 1526 2001 in 1527 1527 - if pkgs = [] && package <> None then 1528 1528 - Error (Package_not_found (Option.get package)) 1529 1529 - else begin 1530 1530 - Log.app (fun m -> m "Syncing opam files for %d packages..." (List.length pkgs)); 1531 1531 - let synced = ref [] in 1532 1532 - let unchanged = ref [] in 1533 1533 - let missing = ref [] in 1534 1534 - let orphaned = ref [] in 1535 2002 1536 1536 - (* Check each package *) 1537 1537 - List.iter (fun pkg -> 1538 1538 - (* Check if the subtree exists in monorepo *) 1539 1539 - let monorepo = Config.Paths.monorepo config in 1540 1540 - let subtree_prefix = Package.subtree_prefix pkg in 1541 1541 - let subtree_exists = Git.Subtree.exists ~fs ~repo:monorepo ~prefix:subtree_prefix in 2003 2003 + Log.app (fun m -> 2004 2004 + m "Generating opam-repo entries for %d packages..." (List.length pkgs)); 1542 2005 1543 1543 - if not subtree_exists then 1544 1544 - (* Subtree doesn't exist - package is orphaned in opam-repo *) 1545 1545 - orphaned := Package.name pkg :: !orphaned 1546 1546 - else 1547 1547 - match sync_opam_file ~proc ~fs ~config pkg with 1548 1548 - | `Synced name -> synced := name :: !synced 1549 1549 - | `Unchanged name -> unchanged := name :: !unchanged 1550 1550 - | `Missing name -> missing := name :: !missing) 1551 1551 - pkgs; 2006 2006 + let opam_repo = Config.Paths.opam_repo config in 2007 2007 + let synced = ref [] in 2008 2008 + let unchanged = ref [] in 2009 2009 + 2010 2010 + (* Generate each package *) 2011 2011 + List.iter 2012 2012 + (fun pkg -> 2013 2013 + (* Destination: opam-repo/packages/<name>/<name>.dev/opam *) 2014 2014 + let pkg_dir = 2015 2015 + Fpath.(opam_repo / "packages" / pkg.pkg_name / (pkg.pkg_name ^ ".dev")) 2016 2016 + in 2017 2017 + let dst_path = Eio.Path.(fs / Fpath.to_string pkg_dir / "opam") in 1552 2018 1553 1553 - let result = { 2019 2019 + let dst_content = read_file_opt dst_path in 2020 2020 + if Some pkg.opam_content = dst_content then 2021 2021 + unchanged := pkg.pkg_name :: !unchanged 2022 2022 + else begin 2023 2023 + (* Create destination directory if needed *) 2024 2024 + let pkg_dir_eio = Eio.Path.(fs / Fpath.to_string pkg_dir) in 2025 2025 + (try Eio.Path.mkdirs ~perm:0o755 pkg_dir_eio with Eio.Io _ -> ()); 2026 2026 + (* Write the opam file *) 2027 2027 + Log.info (fun m -> m "Generating %s.opam in opam-repo" pkg.pkg_name); 2028 2028 + Eio.Path.save ~create:(`Or_truncate 0o644) dst_path pkg.opam_content; 2029 2029 + (* Stage the change *) 2030 2030 + let opam_repo_eio = Eio.Path.(fs / Fpath.to_string opam_repo) in 2031 2031 + let rel_path = 2032 2032 + Printf.sprintf "packages/%s/%s.dev/opam" pkg.pkg_name pkg.pkg_name 2033 2033 + in 2034 2034 + Eio.Switch.run (fun sw -> 2035 2035 + let child = 2036 2036 + Eio.Process.spawn proc ~sw ~cwd:opam_repo_eio 2037 2037 + [ "git"; "add"; rel_path ] 2038 2038 + in 2039 2039 + ignore (Eio.Process.await child)); 2040 2040 + synced := pkg.pkg_name :: !synced 2041 2041 + end) 2042 2042 + pkgs; 2043 2043 + 2044 2044 + (* Find and delete orphaned packages *) 2045 2045 + let generated_names = 2046 2046 + List.map (fun p -> p.pkg_name) pkgs 2047 2047 + |> List.sort_uniq String.compare 2048 2048 + in 2049 2049 + let existing_packages = list_opam_repo_packages ~fs ~config in 2050 2050 + let orphaned = 2051 2051 + List.filter 2052 2052 + (fun name -> not (List.mem name generated_names)) 2053 2053 + existing_packages 2054 2054 + in 2055 2055 + 2056 2056 + (* Delete orphans only if we're doing a full sync (no package filter) *) 2057 2057 + let deleted = 2058 2058 + if package = None then begin 2059 2059 + List.iter 2060 2060 + (fun name -> 2061 2061 + Log.info (fun m -> m "Removing orphaned package: %s" name); 2062 2062 + ignore (delete_opam_repo_package ~proc ~fs ~config name)) 2063 2063 + orphaned; 2064 2064 + orphaned 2065 2065 + end 2066 2066 + else [] 2067 2067 + in 2068 2068 + 2069 2069 + let result = 2070 2070 + { 1554 2071 synced = List.rev !synced; 1555 2072 unchanged = List.rev !unchanged; 1556 1556 - missing = List.rev !missing; 1557 1557 - orphaned = List.rev !orphaned; 1558 1558 - } in 2073 2073 + missing = []; (* No longer used in generation-based approach *) 2074 2074 + orphaned = deleted; 2075 2075 + } 2076 2076 + in 1559 2077 1560 1560 - (* Commit if there were changes *) 1561 1561 - if result.synced <> [] then begin 1562 1562 - let opam_repo = Config.Paths.opam_repo config in 1563 1563 - let opam_repo_eio = Eio.Path.(fs / Fpath.to_string opam_repo) in 1564 1564 - let msg = Printf.sprintf "Sync opam files from monorepo (%d packages)" 1565 1565 - (List.length result.synced) in 1566 1566 - Eio.Switch.run (fun sw -> 1567 1567 - let child = 1568 1568 - Eio.Process.spawn proc ~sw ~cwd:opam_repo_eio 1569 1569 - [ "git"; "commit"; "-m"; msg ] 1570 1570 - in 1571 1571 - ignore (Eio.Process.await child)); 1572 1572 - Log.app (fun m -> m "Committed opam sync: %s" msg) 1573 1573 - end; 1574 1574 - 1575 1575 - (* Report orphaned packages *) 1576 1576 - if result.orphaned <> [] then begin 1577 1577 - Log.warn (fun m -> m "Found %d orphaned packages in opam-repo (subtree missing from monorepo):" 1578 1578 - (List.length result.orphaned)); 1579 1579 - List.iter (fun name -> 1580 1580 - Log.warn (fun m -> m " %s" name)) 1581 1581 - result.orphaned; 1582 1582 - Log.warn (fun m -> m "To remove, delete from opam-repo/packages/ and commit.") 1583 1583 - end; 2078 2078 + (* Commit if there were changes *) 2079 2079 + if result.synced <> [] || result.orphaned <> [] then begin 2080 2080 + let opam_repo_eio = Eio.Path.(fs / Fpath.to_string opam_repo) in 2081 2081 + let msg = 2082 2082 + let parts = [] in 2083 2083 + let parts = 2084 2084 + if result.synced <> [] then 2085 2085 + Printf.sprintf "updated %d" (List.length result.synced) :: parts 2086 2086 + else parts 2087 2087 + in 2088 2088 + let parts = 2089 2089 + if result.orphaned <> [] then 2090 2090 + Printf.sprintf "removed %d" (List.length result.orphaned) :: parts 2091 2091 + else parts 2092 2092 + in 2093 2093 + Printf.sprintf "Sync opam files from monorepo (%s packages)" 2094 2094 + (String.concat ", " parts) 2095 2095 + in 2096 2096 + Eio.Switch.run (fun sw -> 2097 2097 + let child = 2098 2098 + Eio.Process.spawn proc ~sw ~cwd:opam_repo_eio 2099 2099 + [ "git"; "commit"; "-m"; msg ] 2100 2100 + in 2101 2101 + ignore (Eio.Process.await child)); 2102 2102 + Log.app (fun m -> m "Committed opam sync: %s" msg) 2103 2103 + end; 1584 2104 1585 1585 - Log.app (fun m -> m "%a" pp_opam_sync_result result); 1586 1586 - Ok result 1587 1587 - end 2105 2105 + Log.app (fun m -> m "%a" pp_opam_sync_result result); 2106 2106 + Ok result 1588 2107 1589 2108 let add ~proc ~fs ~config ~package () = 1590 2109 let fs_t = fs_typed fs in ··· 1616 2135 1617 2136 (* Changes command - generate weekly changelogs using Claude *) 1618 2137 1619 1619 - let changes ~proc ~fs ~config ~clock ?package ?(weeks = 1) ?(history = 12) ?(dry_run = false) () = 2138 2138 + let changes ~proc ~fs ~config ~clock ?package ?(weeks = 1) ?(history = 12) 2139 2139 + ?(dry_run = false) () = 1620 2140 let fs_t = fs_typed fs in 1621 2141 let monorepo = Config.Paths.monorepo config in 1622 2142 1623 2143 (* Get current time and calculate week boundaries *) 1624 2144 let now = Eio.Time.now clock in 1625 1625 - let now_ptime = match Ptime.of_float_s now with 1626 1626 - | Some t -> t 1627 1627 - | None -> Ptime.v (0, 0L) (* fallback to epoch *) 2145 2145 + let now_ptime = 2146 2146 + match Ptime.of_float_s now with Some t -> t | None -> Ptime.v (0, 0L) 2147 2147 + (* fallback to epoch *) 1628 2148 in 1629 2149 1630 2150 match discover_packages ~fs:(fs_t :> _ Eio.Path.t) ~config () with 1631 2151 | Error e -> Error e 1632 2152 | Ok all_pkgs -> 1633 2153 let repos = unique_repos all_pkgs in 1634 1634 - let repos = match package with 2154 2154 + let repos = 2155 2155 + match package with 1635 2156 | None -> repos 1636 2157 | Some name -> List.filter (fun p -> Package.repo_name p = name) repos 1637 2158 in 1638 2159 if repos = [] && package <> None then 1639 2160 Error (Package_not_found (Option.get package)) 1640 2161 else begin 1641 1641 - Log.info (fun m -> m "Processing changelogs for %d repositories" (List.length repos)); 2162 2162 + Log.info (fun m -> 2163 2163 + m "Processing changelogs for %d repositories" (List.length repos)); 1642 2164 1643 2165 (* Process each repository *) 1644 2166 let all_changes_files = ref [] in 1645 2167 let rec process_repos = function 1646 2168 | [] -> Ok () 1647 1647 - | pkg :: rest -> 2169 2169 + | pkg :: rest -> ( 1648 2170 let repo_name = Package.repo_name pkg in 1649 2171 1650 2172 Log.info (fun m -> m "Processing %s" repo_name); ··· 1652 2174 (* Load existing changes from .changes/<repo>.json *) 1653 2175 match Changes.load ~fs:fs_t ~monorepo repo_name with 1654 2176 | Error e -> Error (Claude_error e) 1655 1655 - | Ok changes_file -> 2177 2177 + | Ok changes_file -> ( 1656 2178 (* Process each week *) 1657 2179 let rec process_weeks week_offset updated_cf = 1658 2180 if week_offset >= weeks then Ok updated_cf 1659 2181 else begin 1660 2182 (* Calculate week boundaries *) 1661 1661 - let offset_seconds = float_of_int (week_offset * 7 * 24 * 60 * 60) in 1662 1662 - let week_time = match Ptime.of_float_s (now -. offset_seconds) with 2183 2183 + let offset_seconds = 2184 2184 + float_of_int (week_offset * 7 * 24 * 60 * 60) 2185 2185 + in 2186 2186 + let week_time = 2187 2187 + match Ptime.of_float_s (now -. offset_seconds) with 1663 2188 | Some t -> t 1664 2189 | None -> now_ptime 1665 2190 in 1666 1666 - let week_start, week_end = Changes.week_of_ptime week_time in 2191 2191 + let week_start, week_end = 2192 2192 + Changes.week_of_ptime week_time 2193 2193 + in 1667 2194 1668 2195 (* Skip if week already has an entry *) 1669 2196 if Changes.has_week updated_cf ~week_start then begin 1670 1670 - Log.info (fun m -> m " Week %s already has entry, skipping" week_start); 2197 2197 + Log.info (fun m -> 2198 2198 + m " Week %s already has entry, skipping" week_start); 1671 2199 process_weeks (week_offset + 1) updated_cf 1672 2200 end 1673 2201 else begin 1674 2202 (* Get commits for this week *) 1675 2203 let since = week_start ^ " 00:00:00" in 1676 2204 let until = week_end ^ " 23:59:59" in 1677 1677 - match Git.log ~proc ~fs:fs_t ~since ~until ~path:repo_name monorepo with 2205 2205 + match 2206 2206 + Git.log ~proc ~fs:fs_t ~since ~until ~path:repo_name 2207 2207 + monorepo 2208 2208 + with 1678 2209 | Error e -> Error (Git_error e) 1679 2210 | Ok commits -> 1680 2211 if commits = [] then begin 1681 1681 - Log.info (fun m -> m " No commits for week %s" week_start); 2212 2212 + Log.info (fun m -> 2213 2213 + m " No commits for week %s" week_start); 1682 2214 process_weeks (week_offset + 1) updated_cf 1683 2215 end 1684 2216 else begin 1685 1685 - Log.info (fun m -> m " Found %d commits for week %s" (List.length commits) week_start); 2217 2217 + Log.info (fun m -> 2218 2218 + m " Found %d commits for week %s" 2219 2219 + (List.length commits) week_start); 1686 2220 1687 2221 if dry_run then begin 1688 1688 - Log.app (fun m -> m " [DRY RUN] Would analyze %d commits for %s week %s" 1689 1689 - (List.length commits) repo_name week_start); 2222 2222 + Log.app (fun m -> 2223 2223 + m 2224 2224 + " [DRY RUN] Would analyze %d commits \ 2225 2225 + for %s week %s" 2226 2226 + (List.length commits) repo_name week_start); 1690 2227 process_weeks (week_offset + 1) updated_cf 1691 2228 end 1692 2229 else begin 1693 2230 (* Analyze commits with Claude *) 1694 2231 Eio.Switch.run @@ fun sw -> 1695 1695 - match Changes.analyze_commits ~sw ~process_mgr:proc ~clock 1696 1696 - ~repository:repo_name ~week_start ~week_end commits with 2232 2232 + match 2233 2233 + Changes.analyze_commits ~sw ~process_mgr:proc 2234 2234 + ~clock ~repository:repo_name ~week_start 2235 2235 + ~week_end commits 2236 2236 + with 1697 2237 | Error e -> Error (Claude_error e) 1698 2238 | Ok None -> 1699 1699 - Log.info (fun m -> m " No user-facing changes for week %s" week_start); 2239 2239 + Log.info (fun m -> 2240 2240 + m " No user-facing changes for week %s" 2241 2241 + week_start); 1700 2242 process_weeks (week_offset + 1) updated_cf 1701 2243 | Ok (Some response) -> 1702 1702 - Log.app (fun m -> m " Generated changelog for %s week %s" repo_name week_start); 2244 2244 + Log.app (fun m -> 2245 2245 + m " Generated changelog for %s week %s" 2246 2246 + repo_name week_start); 1703 2247 (* Create new entry *) 1704 1704 - let first_hash = (List.hd commits).Git.hash in 1705 1705 - let last_hash = (List.hd (List.rev commits)).Git.hash in 1706 1706 - let entry : Changes.weekly_entry = { 1707 1707 - week_start; 1708 1708 - week_end; 1709 1709 - summary = response.Changes.summary; 1710 1710 - changes = response.Changes.changes; 1711 1711 - commit_range = { 1712 1712 - from_hash = String.sub first_hash 0 (min 7 (String.length first_hash)); 1713 1713 - to_hash = String.sub last_hash 0 (min 7 (String.length last_hash)); 1714 1714 - count = List.length commits; 1715 1715 - }; 1716 1716 - } in 2248 2248 + let first_hash = 2249 2249 + (List.hd commits).Git.hash 2250 2250 + in 2251 2251 + let last_hash = 2252 2252 + (List.hd (List.rev commits)).Git.hash 2253 2253 + in 2254 2254 + let entry : Changes.weekly_entry = 2255 2255 + { 2256 2256 + week_start; 2257 2257 + week_end; 2258 2258 + summary = response.Changes.summary; 2259 2259 + changes = response.Changes.changes; 2260 2260 + commit_range = 2261 2261 + { 2262 2262 + from_hash = 2263 2263 + String.sub first_hash 0 2264 2264 + (min 7 2265 2265 + (String.length first_hash)); 2266 2266 + to_hash = 2267 2267 + String.sub last_hash 0 2268 2268 + (min 7 (String.length last_hash)); 2269 2269 + count = List.length commits; 2270 2270 + }; 2271 2271 + } 2272 2272 + in 1717 2273 (* Add entry (sorted by date descending) *) 1718 2274 let new_entries = 1719 2275 entry :: updated_cf.Changes.entries 1720 2276 |> List.sort (fun e1 e2 -> 1721 1721 - String.compare e2.Changes.week_start e1.Changes.week_start) 2277 2277 + String.compare e2.Changes.week_start 2278 2278 + e1.Changes.week_start) 1722 2279 in 1723 2280 process_weeks (week_offset + 1) 1724 2281 { updated_cf with entries = new_entries } ··· 1729 2286 in 1730 2287 match process_weeks 0 changes_file with 1731 2288 | Error e -> Error e 1732 1732 - | Ok updated_cf -> 2289 2289 + | Ok updated_cf -> ( 1733 2290 (* Save if changed and not dry run *) 1734 2291 let save_result = 1735 1735 - if not dry_run && updated_cf.entries <> changes_file.entries then 2292 2292 + if 2293 2293 + (not dry_run) 2294 2294 + && updated_cf.entries <> changes_file.entries 2295 2295 + then ( 1736 2296 match Changes.save ~fs:fs_t ~monorepo updated_cf with 1737 2297 | Error e -> Error (Claude_error e) 1738 2298 | Ok () -> 1739 1739 - Log.app (fun m -> m "Saved .changes/%s.json" repo_name); 1740 1740 - Ok () 2299 2299 + Log.app (fun m -> 2300 2300 + m "Saved .changes/%s.json" repo_name); 2301 2301 + Ok ()) 1741 2302 else Ok () 1742 2303 in 1743 2304 match save_result with 1744 2305 | Error e -> Error e 1745 2306 | Ok () -> 1746 2307 all_changes_files := updated_cf :: !all_changes_files; 1747 1747 - process_repos rest 2308 2308 + process_repos rest))) 1748 2309 in 1749 2310 match process_repos repos with 1750 2311 | Error e -> Error e 1751 2312 | Ok () -> 1752 2313 (* Generate aggregated CHANGES.md *) 1753 1753 - if not dry_run && !all_changes_files <> [] then begin 2314 2314 + if (not dry_run) && !all_changes_files <> [] then begin 1754 2315 let markdown = Changes.aggregate ~history !all_changes_files in 1755 1755 - let changes_md_path = Eio.Path.(fs_t / Fpath.to_string monorepo / "CHANGES.md") in 1756 1756 - Eio.Path.save ~create:(`Or_truncate 0o644) changes_md_path markdown; 2316 2316 + let changes_md_path = 2317 2317 + Eio.Path.(fs_t / Fpath.to_string monorepo / "CHANGES.md") 2318 2318 + in 2319 2319 + Eio.Path.save ~create:(`Or_truncate 0o644) changes_md_path 2320 2320 + markdown; 1757 2321 Log.app (fun m -> m "Generated CHANGES.md at monorepo root") 1758 2322 end; 1759 2323 Ok () ··· 1761 2325 1762 2326 (* Daily changes command - generate daily changelogs using Claude *) 1763 2327 1764 1764 - let changes_daily ~proc ~fs ~config ~clock ?package ?(days = 1) ?(history = 30) ?(dry_run = false) ?(aggregate = false) () = 2328 2328 + let changes_daily ~proc ~fs ~config ~clock ?package ?(days = 1) ?(history = 30) 2329 2329 + ?(dry_run = false) ?(aggregate = false) () = 1765 2330 let fs_t = fs_typed fs in 1766 2331 let monorepo = Config.Paths.monorepo config in 1767 2332 1768 2333 (* Get current time *) 1769 2334 let now = Eio.Time.now clock in 1770 1770 - let now_ptime = match Ptime.of_float_s now with 1771 1771 - | Some t -> t 1772 1772 - | None -> Ptime.v (0, 0L) (* fallback to epoch *) 2335 2335 + let now_ptime = 2336 2336 + match Ptime.of_float_s now with Some t -> t | None -> Ptime.v (0, 0L) 2337 2337 + (* fallback to epoch *) 1773 2338 in 1774 2339 1775 2340 match discover_packages ~fs:(fs_t :> _ Eio.Path.t) ~config () with 1776 2341 | Error e -> Error e 1777 2342 | Ok all_pkgs -> 1778 2343 let repos = unique_repos all_pkgs in 1779 1779 - let repos = match package with 2344 2344 + let repos = 2345 2345 + match package with 1780 2346 | None -> repos 1781 2347 | Some name -> List.filter (fun p -> Package.repo_name p = name) repos 1782 2348 in 1783 2349 if repos = [] && package <> None then 1784 2350 Error (Package_not_found (Option.get package)) 1785 2351 else begin 1786 1786 - Log.info (fun m -> m "Processing daily changelogs for %d repositories" (List.length repos)); 2352 2352 + Log.info (fun m -> 2353 2353 + m "Processing daily changelogs for %d repositories" 2354 2354 + (List.length repos)); 1787 2355 1788 2356 (* Process each repository *) 1789 2357 let all_changes_files = ref [] in 1790 2358 let rec process_repos = function 1791 2359 | [] -> Ok () 1792 1792 - | pkg :: rest -> 2360 2360 + | pkg :: rest -> ( 1793 2361 let repo_name = Package.repo_name pkg in 1794 2362 1795 2363 Log.info (fun m -> m "Processing %s" repo_name); ··· 1799 2367 if day_offset >= days then Ok () 1800 2368 else begin 1801 2369 (* Calculate day boundaries *) 1802 1802 - let offset_seconds = float_of_int (day_offset * 24 * 60 * 60) in 1803 1803 - let day_time = match Ptime.of_float_s (now -. offset_seconds) with 2370 2370 + let offset_seconds = 2371 2371 + float_of_int (day_offset * 24 * 60 * 60) 2372 2372 + in 2373 2373 + let day_time = 2374 2374 + match Ptime.of_float_s (now -. offset_seconds) with 1804 2375 | Some t -> t 1805 2376 | None -> now_ptime 1806 2377 in ··· 1811 2382 (* For today, skip only if file has entries (may need to catch new commits) *) 1812 2383 let should_skip = 1813 2384 if is_today then 1814 1814 - Changes.daily_exists ~fs:fs_t ~monorepo ~date repo_name && 1815 1815 - (match Changes.load_daily ~fs:fs_t ~monorepo ~date repo_name with 1816 1816 - | Ok cf -> Changes.has_day cf ~date 1817 1817 - | Error _ -> false) 1818 1818 - else 1819 2385 Changes.daily_exists ~fs:fs_t ~monorepo ~date repo_name 2386 2386 + && 2387 2387 + match 2388 2388 + Changes.load_daily ~fs:fs_t ~monorepo ~date repo_name 2389 2389 + with 2390 2390 + | Ok cf -> Changes.has_day cf ~date 2391 2391 + | Error _ -> false 2392 2392 + else Changes.daily_exists ~fs:fs_t ~monorepo ~date repo_name 1820 2393 in 1821 2394 if should_skip then begin 1822 1822 - Log.info (fun m -> m " Day %s already processed, skipping" date); 1823 1823 - (match Changes.load_daily ~fs:fs_t ~monorepo ~date repo_name with 1824 1824 - | Ok cf -> all_changes_files := cf :: !all_changes_files 1825 1825 - | Error _ -> ()); 2395 2395 + Log.info (fun m -> 2396 2396 + m " Day %s already processed, skipping" date); 2397 2397 + (match 2398 2398 + Changes.load_daily ~fs:fs_t ~monorepo ~date repo_name 2399 2399 + with 2400 2400 + | Ok cf -> all_changes_files := cf :: !all_changes_files 2401 2401 + | Error _ -> ()); 1826 2402 process_days (day_offset + 1) 1827 2403 end 1828 2404 else 1829 2405 (* Load existing daily changes from .changes/<repo>-<date>.json *) 1830 1830 - match Changes.load_daily ~fs:fs_t ~monorepo ~date repo_name with 2406 2406 + match 2407 2407 + Changes.load_daily ~fs:fs_t ~monorepo ~date repo_name 2408 2408 + with 1831 2409 | Error e -> Error (Claude_error e) 1832 1832 - | Ok changes_file -> 2410 2410 + | Ok changes_file -> ( 1833 2411 (* Get commits for this day *) 1834 2412 let since = date ^ " 00:00:00" in 1835 2413 let until = date ^ " 23:59:59" in 1836 1836 - match Git.log ~proc ~fs:fs_t ~since ~until ~path:repo_name monorepo with 2414 2414 + match 2415 2415 + Git.log ~proc ~fs:fs_t ~since ~until ~path:repo_name 2416 2416 + monorepo 2417 2417 + with 1837 2418 | Error e -> Error (Git_error e) 1838 2419 | Ok commits -> 1839 2420 if commits = [] then begin 1840 1840 - Log.info (fun m -> m " No commits for day %s" date); 2421 2421 + Log.info (fun m -> 2422 2422 + m " No commits for day %s" date); 1841 2423 process_days (day_offset + 1) 1842 2424 end 1843 2425 else begin 1844 1844 - Log.info (fun m -> m " Found %d commits for day %s" (List.length commits) date); 2426 2426 + Log.info (fun m -> 2427 2427 + m " Found %d commits for day %s" 2428 2428 + (List.length commits) date); 1845 2429 1846 2430 if dry_run then begin 1847 1847 - Log.app (fun m -> m " [DRY RUN] Would analyze %d commits for %s on %s" 1848 1848 - (List.length commits) repo_name date); 2431 2431 + Log.app (fun m -> 2432 2432 + m 2433 2433 + " [DRY RUN] Would analyze %d commits \ 2434 2434 + for %s on %s" 2435 2435 + (List.length commits) repo_name date); 1849 2436 process_days (day_offset + 1) 1850 2437 end 1851 2438 else begin 1852 2439 (* Analyze commits with Claude *) 1853 2440 Eio.Switch.run @@ fun sw -> 1854 1854 - match Changes.analyze_commits_daily ~sw ~process_mgr:proc ~clock 1855 1855 - ~repository:repo_name ~date commits with 2441 2441 + match 2442 2442 + Changes.analyze_commits_daily ~sw 2443 2443 + ~process_mgr:proc ~clock 2444 2444 + ~repository:repo_name ~date commits 2445 2445 + with 1856 2446 | Error e -> Error (Claude_error e) 1857 2447 | Ok None -> 1858 1858 - Log.info (fun m -> m " No user-facing changes for day %s" date); 2448 2448 + Log.info (fun m -> 2449 2449 + m " No user-facing changes for day %s" 2450 2450 + date); 1859 2451 process_days (day_offset + 1) 1860 1860 - | Ok (Some response) -> 1861 1861 - Log.app (fun m -> m " Generated changelog for %s on %s" repo_name date); 2452 2452 + | Ok (Some response) -> ( 2453 2453 + Log.app (fun m -> 2454 2454 + m " Generated changelog for %s on %s" 2455 2455 + repo_name date); 1862 2456 (* Extract unique contributors from commits *) 1863 2457 let contributors = 1864 2458 commits 1865 1865 - |> List.map (fun (c : Git.log_entry) -> c.author) 2459 2459 + |> List.map (fun (c : Git.log_entry) -> 2460 2460 + c.author) 1866 2461 |> List.sort_uniq String.compare 1867 2462 in 1868 2463 (* Get repo URL from package dev_repo *) ··· 1870 2465 let uri = Package.dev_repo pkg in 1871 2466 let url = Uri.to_string uri in 1872 2467 (* Strip git+ prefix if present for display *) 1873 1873 - if String.starts_with ~prefix:"git+" url then 1874 1874 - Some (String.sub url 4 (String.length url - 4)) 1875 1875 - else 1876 1876 - Some url 2468 2468 + if String.starts_with ~prefix:"git+" url 2469 2469 + then 2470 2470 + Some 2471 2471 + (String.sub url 4 2472 2472 + (String.length url - 4)) 2473 2473 + else Some url 1877 2474 in 1878 2475 (* Create new entry with hour and timestamp *) 1879 1879 - let first_hash = (List.hd commits).Git.hash in 1880 1880 - let last_hash = (List.hd (List.rev commits)).Git.hash in 1881 1881 - let (_, ((hour, _, _), _)) = Ptime.to_date_time now_ptime in 1882 1882 - let entry : Changes.daily_entry = { 1883 1883 - date; 1884 1884 - hour; 1885 1885 - timestamp = now_ptime; 1886 1886 - summary = response.Changes.summary; 1887 1887 - changes = response.Changes.changes; 1888 1888 - commit_range = { 1889 1889 - from_hash = String.sub first_hash 0 (min 7 (String.length first_hash)); 1890 1890 - to_hash = String.sub last_hash 0 (min 7 (String.length last_hash)); 1891 1891 - count = List.length commits; 1892 1892 - }; 1893 1893 - contributors; 1894 1894 - repo_url; 1895 1895 - } in 2476 2476 + let first_hash = 2477 2477 + (List.hd commits).Git.hash 2478 2478 + in 2479 2479 + let last_hash = 2480 2480 + (List.hd (List.rev commits)).Git.hash 2481 2481 + in 2482 2482 + let _, ((hour, _, _), _) = 2483 2483 + Ptime.to_date_time now_ptime 2484 2484 + in 2485 2485 + let entry : Changes.daily_entry = 2486 2486 + { 2487 2487 + date; 2488 2488 + hour; 2489 2489 + timestamp = now_ptime; 2490 2490 + summary = response.Changes.summary; 2491 2491 + changes = response.Changes.changes; 2492 2492 + commit_range = 2493 2493 + { 2494 2494 + from_hash = 2495 2495 + String.sub first_hash 0 2496 2496 + (min 7 2497 2497 + (String.length first_hash)); 2498 2498 + to_hash = 2499 2499 + String.sub last_hash 0 2500 2500 + (min 7 (String.length last_hash)); 2501 2501 + count = List.length commits; 2502 2502 + }; 2503 2503 + contributors; 2504 2504 + repo_url; 2505 2505 + } 2506 2506 + in 1896 2507 (* Add entry (sorted by timestamp descending) *) 1897 2508 let new_entries = 1898 2509 entry :: changes_file.Changes.entries 1899 2510 |> List.sort (fun e1 e2 -> 1900 1900 - Ptime.compare e2.Changes.timestamp e1.Changes.timestamp) 2511 2511 + Ptime.compare e2.Changes.timestamp 2512 2512 + e1.Changes.timestamp) 2513 2513 + in 2514 2514 + let updated_cf = 2515 2515 + { 2516 2516 + changes_file with 2517 2517 + Changes.entries = new_entries; 2518 2518 + } 1901 2519 in 1902 1902 - let updated_cf = { changes_file with Changes.entries = new_entries } in 1903 2520 (* Save the per-day file *) 1904 1904 - match Changes.save_daily ~fs:fs_t ~monorepo ~date updated_cf with 2521 2521 + match 2522 2522 + Changes.save_daily ~fs:fs_t ~monorepo 2523 2523 + ~date updated_cf 2524 2524 + with 1905 2525 | Error e -> Error (Claude_error e) 1906 2526 | Ok () -> 1907 1907 - Log.app (fun m -> m "Saved .changes/%s-%s.json" repo_name date); 1908 1908 - all_changes_files := updated_cf :: !all_changes_files; 1909 1909 - process_days (day_offset + 1) 2527 2527 + Log.app (fun m -> 2528 2528 + m "Saved .changes/%s-%s.json" 2529 2529 + repo_name date); 2530 2530 + all_changes_files := 2531 2531 + updated_cf :: !all_changes_files; 2532 2532 + process_days (day_offset + 1)) 1910 2533 end 1911 1911 - end 2534 2534 + end) 1912 2535 end 1913 2536 in 1914 2537 match process_days 0 with 1915 2538 | Error e -> Error e 1916 1916 - | Ok () -> process_repos rest 2539 2539 + | Ok () -> process_repos rest) 1917 2540 in 1918 2541 match process_repos repos with 1919 2542 | Error e -> Error e 1920 2543 | Ok () -> 1921 2544 (* Generate aggregated DAILY-CHANGES.md *) 1922 1922 - if not dry_run && !all_changes_files <> [] then begin 1923 1923 - let raw_markdown = Changes.aggregate_daily ~history !all_changes_files in 2545 2545 + if (not dry_run) && !all_changes_files <> [] then begin 2546 2546 + let raw_markdown = 2547 2547 + Changes.aggregate_daily ~history !all_changes_files 2548 2548 + in 1924 2549 (* Refine the markdown through Claude for better narrative *) 1925 2550 Log.info (fun m -> m "Refining daily changelog with Claude..."); 1926 1926 - let markdown = Eio.Switch.run @@ fun sw -> 1927 1927 - match Changes.refine_daily_changelog ~sw ~process_mgr:proc ~clock raw_markdown with 2551 2551 + let markdown = 2552 2552 + Eio.Switch.run @@ fun sw -> 2553 2553 + match 2554 2554 + Changes.refine_daily_changelog ~sw ~process_mgr:proc ~clock 2555 2555 + raw_markdown 2556 2556 + with 1928 2557 | Ok refined -> 1929 1929 - Log.app (fun m -> m "Refined daily changelog for readability"); 2558 2558 + Log.app (fun m -> 2559 2559 + m "Refined daily changelog for readability"); 1930 2560 refined 1931 2561 | Error e -> 1932 1932 - Log.warn (fun m -> m "Failed to refine changelog: %s (using raw version)" e); 2562 2562 + Log.warn (fun m -> 2563 2563 + m "Failed to refine changelog: %s (using raw version)" e); 1933 2564 raw_markdown 1934 2565 in 1935 1935 - let changes_md_path = Eio.Path.(fs_t / Fpath.to_string monorepo / "DAILY-CHANGES.md") in 1936 1936 - Eio.Path.save ~create:(`Or_truncate 0o644) changes_md_path markdown; 2566 2566 + let changes_md_path = 2567 2567 + Eio.Path.(fs_t / Fpath.to_string monorepo / "DAILY-CHANGES.md") 2568 2568 + in 2569 2569 + Eio.Path.save ~create:(`Or_truncate 0o644) changes_md_path 2570 2570 + markdown; 1937 2571 Log.app (fun m -> m "Generated DAILY-CHANGES.md at monorepo root") 1938 2572 end; 1939 2573 (* Generate aggregated JSON file if requested *) 1940 1940 - if not dry_run && aggregate then begin 2574 2574 + if (not dry_run) && aggregate then begin 1941 2575 let today = Changes.date_of_ptime now_ptime in 1942 2576 let git_head = 1943 2577 match Git.rev_parse ~proc ~fs:fs_t ~rev:"HEAD" monorepo with 1944 2578 | Ok hash -> String.sub hash 0 (min 7 (String.length hash)) 1945 2579 | Error _ -> "unknown" 1946 2580 in 1947 1947 - match Changes.generate_aggregated ~fs:fs_t ~monorepo ~date:today ~git_head ~now:now_ptime with 1948 1948 - | Ok () -> Log.app (fun m -> m "Generated aggregated file .changes/%s.json" 1949 1949 - (String.concat "" (String.split_on_char '-' today))) 1950 1950 - | Error e -> Log.warn (fun m -> m "Failed to generate aggregated file: %s" e) 2581 2581 + match 2582 2582 + Changes.generate_aggregated ~fs:fs_t ~monorepo ~date:today 2583 2583 + ~git_head ~now:now_ptime 2584 2584 + with 2585 2585 + | Ok () -> 2586 2586 + Log.app (fun m -> 2587 2587 + m "Generated aggregated file .changes/%s.json" 2588 2588 + (String.concat "" (String.split_on_char '-' today))) 2589 2589 + | Error e -> 2590 2590 + Log.warn (fun m -> 2591 2591 + m "Failed to generate aggregated file: %s" e) 1951 2592 end; 1952 2593 Ok () 1953 2594 end 2595 2595 + 2596 2596 + (* ==================== Diff ==================== *) 2597 2597 + 2598 2598 + type diff_entry = { 2599 2599 + repo_name : string; 2600 2600 + handle : string; 2601 2601 + relationship : Forks.relationship; 2602 2602 + commits : Git.log_entry list; 2603 2603 + patches : (string * string) list; (* hash -> patch content *) 2604 2604 + } 2605 2605 + 2606 2606 + type diff_result = { 2607 2607 + entries : diff_entry list; 2608 2608 + forks : Forks.t; 2609 2609 + } 2610 2610 + 2611 2611 + let pp_diff_entry ~show_patch ppf entry = 2612 2612 + let n_commits = List.length entry.commits in 2613 2613 + Fmt.pf ppf "@[<v 2>%a %s (%a, %d commit%s):@," 2614 2614 + Fmt.(styled `Bold string) entry.repo_name 2615 2615 + entry.handle 2616 2616 + Forks.pp_relationship entry.relationship 2617 2617 + n_commits (if n_commits = 1 then "" else "s"); 2618 2618 + List.iter (fun (c : Git.log_entry) -> 2619 2619 + let short_hash = String.sub c.hash 0 (min 7 (String.length c.hash)) in 2620 2620 + Fmt.pf ppf " %a %s %a@," 2621 2621 + Fmt.(styled `Yellow string) short_hash 2622 2622 + c.subject 2623 2623 + Fmt.(styled `Faint string) c.author; 2624 2624 + if show_patch then 2625 2625 + match List.assoc_opt c.hash entry.patches with 2626 2626 + | Some patch -> Fmt.pf ppf "@,%s@," patch 2627 2627 + | None -> ()) 2628 2628 + entry.commits; 2629 2629 + Fmt.pf ppf "@]" 2630 2630 + 2631 2631 + let pp_diff_result ~show_patch ppf result = 2632 2632 + (* First show the summary *) 2633 2633 + Fmt.pf ppf "%a@." (Forks.pp_summary' ~show_all:false) result.forks; 2634 2634 + (* Then show diffs for each entry *) 2635 2635 + if result.entries <> [] then begin 2636 2636 + Fmt.pf ppf "@[<v>%a@]@." 2637 2637 + Fmt.(list ~sep:(any "@,@,") (pp_diff_entry ~show_patch)) result.entries 2638 2638 + end 2639 2639 + 2640 2640 + (** Check if a string looks like a git commit hash (7+ hex chars) *) 2641 2641 + let is_commit_sha s = 2642 2642 + String.length s >= 7 && 2643 2643 + String.for_all (function '0'..'9' | 'a'..'f' | 'A'..'F' -> true | _ -> false) s 2644 2644 + 2645 2645 + let diff ~proc ~fs ~config ~verse_config ?repo ?(refresh=false) ?(patch=false) () = 2646 2646 + let checkouts_path = Config.Paths.checkouts config in 2647 2647 + 2648 2648 + (* Compute fork analysis *) 2649 2649 + let forks = Forks.compute ~proc ~fs ~verse_config ~monopam_config:config ~refresh () in 2650 2650 + 2651 2651 + (* Filter repos if specific one requested *) 2652 2652 + let repos_to_check = match repo with 2653 2653 + | None -> forks.repos 2654 2654 + | Some name -> List.filter (fun r -> r.Forks.repo_name = name) forks.repos 2655 2655 + in 2656 2656 + 2657 2657 + (* For each repo with actionable status, get commits *) 2658 2658 + let entries = 2659 2659 + List.filter_map (fun (r : Forks.repo_analysis) -> 2660 2660 + (* Find actionable verse sources *) 2661 2661 + let actionable = List.filter (fun (_, _, rel) -> 2662 2662 + match rel with 2663 2663 + | Forks.I_am_behind _ -> true 2664 2664 + | Forks.Diverged _ -> true 2665 2665 + | _ -> false) 2666 2666 + r.verse_sources 2667 2667 + in 2668 2668 + match actionable with 2669 2669 + | [] -> None 2670 2670 + | sources -> 2671 2671 + (* Get commits for each actionable source *) 2672 2672 + let entries = List.filter_map (fun (handle, _src, rel) -> 2673 2673 + let checkout_path = Fpath.(checkouts_path / r.repo_name) in 2674 2674 + if not (Git.is_repo ~proc ~fs checkout_path) then None 2675 2675 + else begin 2676 2676 + let remote_name = "verse/" ^ handle in 2677 2677 + let my_ref = "origin/main" in 2678 2678 + let their_ref = remote_name ^ "/main" in 2679 2679 + (* Get commits they have that I don't *) 2680 2680 + match Git.log_range ~proc ~fs ~base:my_ref ~tip:their_ref ~max_count:20 checkout_path with 2681 2681 + | Error _ -> None 2682 2682 + | Ok commits when commits = [] -> None 2683 2683 + | Ok commits -> 2684 2684 + (* Fetch patches if requested *) 2685 2685 + let patches = 2686 2686 + if patch then 2687 2687 + List.filter_map (fun (c : Git.log_entry) -> 2688 2688 + match Git.show_patch ~proc ~fs ~commit:c.hash checkout_path with 2689 2689 + | Ok p -> Some (c.hash, p) 2690 2690 + | Error _ -> None) 2691 2691 + commits 2692 2692 + else [] 2693 2693 + in 2694 2694 + Some { repo_name = r.repo_name; handle; relationship = rel; commits; patches } 2695 2695 + end) 2696 2696 + sources 2697 2697 + in 2698 2698 + match entries with 2699 2699 + | [] -> None 2700 2700 + | _ -> Some entries) 2701 2701 + repos_to_check 2702 2702 + |> List.flatten 2703 2703 + in 2704 2704 + { entries; forks } 2705 2705 + 2706 2706 + (** Result of looking up a specific commit *) 2707 2707 + type commit_info = { 2708 2708 + commit_repo : string; 2709 2709 + commit_handle : string; 2710 2710 + commit_hash : string; 2711 2711 + commit_subject : string; 2712 2712 + commit_author : string; 2713 2713 + commit_patch : string; 2714 2714 + } 2715 2715 + 2716 2716 + (** Show patch for a specific commit SHA from diff output *) 2717 2717 + let diff_show_commit ~proc ~fs ~config ~verse_config ~sha ?(refresh=false) () = 2718 2718 + let checkouts_path = Config.Paths.checkouts config in 2719 2719 + 2720 2720 + (* Compute fork analysis to find which repo has this commit *) 2721 2721 + let forks = Forks.compute ~proc ~fs ~verse_config ~monopam_config:config ~refresh () in 2722 2722 + 2723 2723 + (* Search through repos for this commit *) 2724 2724 + let result = List.find_map (fun (r : Forks.repo_analysis) -> 2725 2725 + let checkout_path = Fpath.(checkouts_path / r.repo_name) in 2726 2726 + if not (Git.is_repo ~proc ~fs checkout_path) then None 2727 2727 + else 2728 2728 + (* Check each verse source *) 2729 2729 + List.find_map (fun (handle, _src, rel) -> 2730 2730 + match rel with 2731 2731 + | Forks.I_am_behind _ | Forks.Diverged _ -> 2732 2732 + let remote_name = "verse/" ^ handle in 2733 2733 + let my_ref = "origin/main" in 2734 2734 + let their_ref = remote_name ^ "/main" in 2735 2735 + (* Get commits they have that I don't *) 2736 2736 + (match Git.log_range ~proc ~fs ~base:my_ref ~tip:their_ref ~max_count:50 checkout_path with 2737 2737 + | Error _ -> None 2738 2738 + | Ok commits -> 2739 2739 + (* Check if our sha matches any commit *) 2740 2740 + let matching = List.find_opt (fun (c : Git.log_entry) -> 2741 2741 + String.starts_with ~prefix:sha c.hash || 2742 2742 + String.starts_with ~prefix:(String.lowercase_ascii sha) (String.lowercase_ascii c.hash)) 2743 2743 + commits 2744 2744 + in 2745 2745 + match matching with 2746 2746 + | None -> None 2747 2747 + | Some c -> 2748 2748 + match Git.show_patch ~proc ~fs ~commit:c.hash checkout_path with 2749 2749 + | Ok patch -> Some { 2750 2750 + commit_repo = r.repo_name; 2751 2751 + commit_handle = handle; 2752 2752 + commit_hash = c.hash; 2753 2753 + commit_subject = c.subject; 2754 2754 + commit_author = c.author; 2755 2755 + commit_patch = patch; 2756 2756 + } 2757 2757 + | Error _ -> None) 2758 2758 + | _ -> None) 2759 2759 + r.verse_sources) 2760 2760 + forks.repos 2761 2761 + in 2762 2762 + result 2763 2763 + 2764 2764 + (* ==================== Pull from Handle ==================== *) 2765 2765 + 2766 2766 + type handle_pull_result = { 2767 2767 + repos_pulled : (string * int) list; 2768 2768 + repos_skipped : string list; 2769 2769 + repos_failed : (string * string) list; 2770 2770 + } 2771 2771 + 2772 2772 + let pp_handle_pull_result ppf result = 2773 2773 + if result.repos_pulled <> [] then begin 2774 2774 + Fmt.pf ppf "@[<v>%a@," Fmt.(styled `Bold string) "Pulled:"; 2775 2775 + List.iter (fun (repo, count) -> 2776 2776 + Fmt.pf ppf " %s: %d commits@," repo count) 2777 2777 + result.repos_pulled; 2778 2778 + Fmt.pf ppf "@]" 2779 2779 + end; 2780 2780 + if result.repos_skipped <> [] then 2781 2781 + Fmt.pf ppf "%a %s@," 2782 2782 + Fmt.(styled `Faint string) "Skipped:" 2783 2783 + (String.concat ", " result.repos_skipped); 2784 2784 + if result.repos_failed <> [] then begin 2785 2785 + Fmt.pf ppf "@[<v>%a@," Fmt.(styled `Red string) "Failed:"; 2786 2786 + List.iter (fun (repo, err) -> 2787 2787 + Fmt.pf ppf " %s: %s@," repo err) 2788 2788 + result.repos_failed; 2789 2789 + Fmt.pf ppf "@]" 2790 2790 + end 2791 2791 + 2792 2792 + let pull_from_handle ~proc ~fs ~config ~verse_config ~handle ?repo ?(refresh=false) () = 2793 2793 + let checkouts_path = Config.Paths.checkouts config in 2794 2794 + 2795 2795 + (* Compute fork analysis *) 2796 2796 + let forks = Forks.compute ~proc ~fs ~verse_config ~monopam_config:config ~refresh () in 2797 2797 + 2798 2798 + (* Filter repos if specific one requested *) 2799 2799 + let repos_to_check = match repo with 2800 2800 + | None -> forks.repos 2801 2801 + | Some name -> List.filter (fun r -> r.Forks.repo_name = name) forks.repos 2802 2802 + in 2803 2803 + 2804 2804 + (* Find repos where this handle has commits we don't have *) 2805 2805 + let repos_pulled = ref [] in 2806 2806 + let repos_skipped = ref [] in 2807 2807 + let repos_failed = ref [] in 2808 2808 + 2809 2809 + List.iter (fun (r : Forks.repo_analysis) -> 2810 2810 + (* Check if this handle has commits for this repo *) 2811 2811 + let handle_source = List.find_opt (fun (h, _, _) -> h = handle) r.verse_sources in 2812 2812 + match handle_source with 2813 2813 + | None -> 2814 2814 + (* Handle doesn't have this repo *) 2815 2815 + () 2816 2816 + | Some (_, _, rel) -> 2817 2817 + let checkout_path = Fpath.(checkouts_path / r.repo_name) in 2818 2818 + if not (Git.is_repo ~proc ~fs checkout_path) then 2819 2819 + repos_skipped := r.repo_name :: !repos_skipped 2820 2820 + else begin 2821 2821 + match rel with 2822 2822 + | Forks.Same_url | Forks.Same_commit | Forks.I_am_ahead _ -> 2823 2823 + repos_skipped := r.repo_name :: !repos_skipped 2824 2824 + | Forks.Not_fetched | Forks.Unrelated -> 2825 2825 + repos_skipped := r.repo_name :: !repos_skipped 2826 2826 + | Forks.I_am_behind count -> 2827 2827 + (* Merge their changes *) 2828 2828 + let remote_ref = "verse/" ^ handle ^ "/main" in 2829 2829 + (match Git.merge ~proc ~fs ~ref_name:remote_ref ~ff_only:true checkout_path with 2830 2830 + | Ok () -> 2831 2831 + repos_pulled := (r.repo_name, count) :: !repos_pulled 2832 2832 + | Error e -> 2833 2833 + repos_failed := (r.repo_name, Fmt.str "%a" Git.pp_error e) :: !repos_failed) 2834 2834 + | Forks.Diverged { their_ahead; _ } -> 2835 2835 + (* Merge their changes (may create a merge commit) *) 2836 2836 + let remote_ref = "verse/" ^ handle ^ "/main" in 2837 2837 + (match Git.merge ~proc ~fs ~ref_name:remote_ref checkout_path with 2838 2838 + | Ok () -> 2839 2839 + repos_pulled := (r.repo_name, their_ahead) :: !repos_pulled 2840 2840 + | Error e -> 2841 2841 + repos_failed := (r.repo_name, Fmt.str "%a" Git.pp_error e) :: !repos_failed) 2842 2842 + end) 2843 2843 + repos_to_check; 2844 2844 + 2845 2845 + Ok { 2846 2846 + repos_pulled = List.rev !repos_pulled; 2847 2847 + repos_skipped = List.rev !repos_skipped; 2848 2848 + repos_failed = List.rev !repos_failed; 2849 2849 + } 2850 2850 + 2851 2851 + (* ==================== Cherry-pick ==================== *) 2852 2852 + 2853 2853 + type cherrypick_result = { 2854 2854 + repo_name : string; 2855 2855 + commit_hash : string; 2856 2856 + commit_subject : string; 2857 2857 + } 2858 2858 + 2859 2859 + let pp_cherrypick_result ppf result = 2860 2860 + let short_hash = String.sub result.commit_hash 0 (min 7 (String.length result.commit_hash)) in 2861 2861 + Fmt.pf ppf "Cherry-picked %a %s into %s@." 2862 2862 + Fmt.(styled `Yellow string) short_hash 2863 2863 + result.commit_subject 2864 2864 + result.repo_name 2865 2865 + 2866 2866 + let cherrypick ~proc ~fs ~config ~verse_config ~sha ?(refresh=false) () = 2867 2867 + let checkouts_path = Config.Paths.checkouts config in 2868 2868 + 2869 2869 + (* First, find the commit *) 2870 2870 + match diff_show_commit ~proc ~fs ~config ~verse_config ~sha ~refresh () with 2871 2871 + | None -> 2872 2872 + Error (Config_error (Printf.sprintf "Commit %s not found in any verse diff" sha)) 2873 2873 + | Some info -> 2874 2874 + let checkout_path = Fpath.(checkouts_path / info.commit_repo) in 2875 2875 + if not (Git.is_repo ~proc ~fs checkout_path) then 2876 2876 + Error (Config_error (Printf.sprintf "No checkout for repository %s" info.commit_repo)) 2877 2877 + else begin 2878 2878 + match Git.cherry_pick ~proc ~fs ~commit:info.commit_hash checkout_path with 2879 2879 + | Ok () -> 2880 2880 + Ok { 2881 2881 + repo_name = info.commit_repo; 2882 2882 + commit_hash = info.commit_hash; 2883 2883 + commit_subject = info.commit_subject; 2884 2884 + } 2885 2885 + | Error e -> 2886 2886 + Error (Git_error e) 2887 2887 + end

+229 -43

lib/monopam.mli

reviewed

··· 35 35 module Forks = Forks 36 36 module Doctor = Doctor 37 37 module Feature = Feature 38 38 + module Dune_project = Dune_project 39 39 + module Opam_transform = Opam_transform 40 40 + module Sources_registry = Sources_registry 41 41 + module Fork_join = Fork_join 42 42 + module Site = Site 38 43 39 44 (** {1 High-Level Operations} *) 40 45 ··· 45 50 | Git_error of Git.error (** Git operation error *) 46 51 | Dirty_state of Package.t list 47 52 (** Operation blocked due to dirty packages *) 53 53 + | Monorepo_dirty (** Monorepo has uncommitted changes *) 48 54 | Package_not_found of string (** Named package not found in opam repo *) 49 55 | Claude_error of string (** Claude API or response parsing error *) 50 56 ··· 52 58 (** [pp_error] formats errors. *) 53 59 54 60 val pp_error_with_hint : error Fmt.t 55 55 - (** [pp_error_with_hint] formats errors with a helpful hint for resolving them. *) 61 61 + (** [pp_error_with_hint] formats errors with a helpful hint for resolving them. 62 62 + *) 56 63 57 64 val error_hint : error -> string option 58 65 (** [error_hint e] returns a hint string for the given error, if available. *) ··· 82 89 ?opam_repo_url:string -> 83 90 unit -> 84 91 (unit, error) result 85 85 - (** [pull ~proc ~fs ~config ?package ?opam_repo_url ()] pulls updates from remotes. 92 92 + (** [pull ~proc ~fs ~config ?package ?opam_repo_url ()] pulls updates from 93 93 + remotes. 86 94 87 95 For each package (or the specified package): 1. Clones or fetches the 88 96 individual checkout 2. Adds or pulls the subtree in the monorepo ··· 96 104 @param fs Eio filesystem 97 105 @param config Monopam configuration 98 106 @param package Optional specific package to pull 99 99 - @param opam_repo_url Optional URL to clone opam-repo from if it doesn't exist *) 107 107 + @param opam_repo_url 108 108 + Optional URL to clone opam-repo from if it doesn't exist *) 100 109 101 110 (** {2 Push} *) 102 111 ··· 128 137 129 138 (** {2 Sync} *) 130 139 131 131 - (** Phase where a sync failure occurred. *) 132 140 type sync_phase = [ `Push_checkout | `Fetch | `Merge | `Subtree | `Push_remote ] 141 141 + (** Phase where a sync failure occurred. *) 133 142 134 134 - (** A failure during sync for a specific repository. *) 135 143 type sync_failure = { 136 144 repo_name : string; 137 145 phase : sync_phase; 138 146 error : Git.error; 139 147 } 148 148 + (** A failure during sync for a specific repository. *) 140 149 141 141 - (** Summary of a sync operation. *) 142 150 type sync_summary = { 143 151 repos_synced : int; 144 152 repos_unchanged : int; ··· 146 154 commits_pushed : int; 147 155 errors : sync_failure list; 148 156 } 157 157 + (** Summary of a sync operation. *) 149 158 150 159 val pp_sync_phase : sync_phase Fmt.t 151 160 (** [pp_sync_phase] formats a sync phase. *) ··· 169 178 (** [sync ~proc ~fs ~config ?package ?remote ?skip_push ?skip_pull ()] 170 179 synchronizes the monorepo with upstream repositories. 171 180 172 172 - This is the primary command for all sync operations. It performs both 173 173 - push and pull operations in the correct order: 174 174 - 1. Validate: check for dirty state (abort if dirty) 175 175 - 2. Push phase: export monorepo changes to checkouts (parallel) 176 176 - 3. Fetch phase: clone/fetch from remotes (parallel) 177 177 - 4. Merge phase: fast-forward merge checkouts (sequential) 178 178 - 5. Subtree phase: pull subtrees into monorepo (sequential) 179 179 - 6. Finalize: write README.md and dune-project (sequential) 180 180 - 7. Remote phase: push to upstream remotes if [~remote:true] (parallel) 181 181 + This is the primary command for all sync operations. It performs both push 182 182 + and pull operations in the correct order: 1. Validate: check for dirty state 183 183 + (abort if dirty) 2. Push phase: export monorepo changes to checkouts 184 184 + (parallel) 3. Fetch phase: clone/fetch from remotes (parallel) 4. Merge 185 185 + phase: fast-forward merge checkouts (sequential) 5. Subtree phase: pull 186 186 + subtrees into monorepo (sequential) 6. Finalize: write README.md and 187 187 + dune-project (sequential) 7. Remote phase: push to upstream remotes if 188 188 + [~remote:true] (parallel) 181 189 182 190 The fetch and remote push phases run concurrently for improved performance. 183 191 ··· 191 199 192 200 (** {2 Opam Metadata Sync} *) 193 201 194 194 - (** Result of syncing opam files from monorepo to opam-repo. *) 195 202 type opam_sync_result = { 196 203 synced : string list; (** Packages that were updated *) 197 204 unchanged : string list; (** Packages that were already in sync *) 198 205 missing : string list; (** Packages where monorepo has no .opam file *) 199 199 - orphaned : string list; (** Packages in opam-repo but subtree missing from monorepo *) 206 206 + orphaned : string list; 207 207 + (** Packages in opam-repo but subtree missing from monorepo *) 200 208 } 209 209 + (** Result of syncing opam files from monorepo to opam-repo. *) 201 210 202 211 val pp_opam_sync_result : opam_sync_result Fmt.t 203 212 (** [pp_opam_sync_result] formats an opam sync result. *) ··· 209 218 ?package:string -> 210 219 unit -> 211 220 (opam_sync_result, error) result 212 212 - (** [sync_opam_files ~proc ~fs ~config ?package ()] synchronizes .opam files 213 213 - from monorepo subtrees to the opam-repo overlay. 221 221 + (** [sync_opam_files ~proc ~fs ~config ?package ()] generates opam-repo entries 222 222 + from monorepo dune-project files. 214 223 215 215 - For each package (or the specified package): 216 216 - 1. Checks if the subtree exists in the monorepo 217 217 - 2. If subtree missing, reports as orphaned (needs manual removal) 218 218 - 3. Reads the .opam file from the monorepo subtree 219 219 - 4. Compares with the opam-repo version 220 220 - 5. If different, copies monorepo → opam-repo (local always wins) 221 221 - 6. Stages and commits changes in opam-repo 224 224 + For each subtree directory in the monorepo: 225 225 + 1. Parses the dune-project to extract source/homepage URL 226 226 + 2. For each .opam file in the subtree: 227 227 + - Transforms it by removing dune-generated comment 228 228 + - Adds dev-repo and url fields derived from dune-project 229 229 + - Writes to opam-repo/packages/<name>/<name>.dev/opam 230 230 + 3. Deletes any orphaned packages in opam-repo not found in monorepo 231 231 + 4. Stages and commits changes in opam-repo 222 232 223 223 - Orphaned packages (in opam-repo but subtree missing from monorepo) are 224 224 - reported with a warning suggesting manual removal. 233 233 + This is a generation-based approach - opam-repo is derived entirely from 234 234 + monorepo dune-project and .opam files. 225 235 226 236 @param proc Eio process manager 227 237 @param fs Eio filesystem 228 238 @param config Monopam configuration 229 229 - @param package Optional specific package to sync *) 239 239 + @param package Optional specific subtree to sync *) 230 240 231 241 (** {2 Package Management} *) 232 242 ··· 302 312 @param config Monopam configuration 303 313 @param pkgs List of packages discovered from the opam overlay *) 304 314 315 315 + (** Information about a package discovered from the monorepo. *) 316 316 + type monorepo_package = { 317 317 + pkg_name : string; (** Package name (from .opam filename) *) 318 318 + subtree : string; (** Subtree directory name *) 319 319 + dev_repo : string; (** dev-repo URL derived from dune-project *) 320 320 + url_src : string; (** url src with branch (e.g., "git+https://...#main") *) 321 321 + opam_content : string; (** Transformed opam file content ready to write *) 322 322 + } 323 323 + 324 324 + val discover_packages_from_monorepo : 325 325 + fs:Eio.Fs.dir_ty Eio.Path.t -> 326 326 + config:Config.t -> 327 327 + ?sources:Sources_registry.t -> 328 328 + unit -> 329 329 + (monorepo_package list, error) result 330 330 + (** [discover_packages_from_monorepo ~fs ~config ?sources ()] scans monorepo 331 331 + subtrees and discovers packages from dune-project files. 332 332 + 333 333 + For each subdirectory of the monorepo with a dune-project file: 334 334 + 1. Checks sources.toml for URL override 335 335 + 2. Falls back to dune-project source/homepage URL 336 336 + 3. For each .opam file in that directory, transforms it with dev-repo and url 337 337 + 338 338 + @param fs Eio filesystem 339 339 + @param config Monopam configuration 340 340 + @param sources Optional sources registry for URL overrides *) 341 341 + 305 342 (** {1 Changelog Generation} *) 306 343 307 344 val changes : ··· 318 355 (** [changes ~proc ~fs ~config ~clock ?package ?weeks ?history ?dry_run ()] 319 356 generates weekly changelog entries using Claude AI. 320 357 321 321 - For each repository (or the specified package's repository): 322 322 - 1. Loads or creates .changes/<repo>.json 323 323 - 2. For each week that doesn't have an entry, retrieves git commits 324 324 - 3. Sends commits to Claude for analysis 325 325 - 4. Saves changelog entries back to .changes/<repo>.json 358 358 + For each repository (or the specified package's repository): 1. Loads or 359 359 + creates .changes/<repo>.json 2. For each week that doesn't have an entry, 360 360 + retrieves git commits 3. Sends commits to Claude for analysis 4. Saves 361 361 + changelog entries back to .changes/<repo>.json 326 362 327 363 Also generates an aggregated CHANGES.md at the monorepo root. 328 364 ··· 347 383 ?aggregate:bool -> 348 384 unit -> 349 385 (unit, error) result 350 350 - (** [changes_daily ~proc ~fs ~config ~clock ?package ?days ?history ?dry_run ?aggregate ()] 351 351 - generates daily changelog entries using Claude AI. 386 386 + (** [changes_daily ~proc ~fs ~config ~clock ?package ?days ?history ?dry_run 387 387 + ?aggregate ()] generates daily changelog entries using Claude AI. 352 388 353 353 - For each repository (or the specified package's repository): 354 354 - 1. Loads or creates .changes/<repo>-daily.json 355 355 - 2. For each day that doesn't have an entry, retrieves git commits 356 356 - 3. Sends commits to Claude for analysis 357 357 - 4. Saves changelog entries back to .changes/<repo>-daily.json 389 389 + For each repository (or the specified package's repository): 1. Loads or 390 390 + creates .changes/<repo>-daily.json 2. For each day that doesn't have an 391 391 + entry, retrieves git commits 3. Sends commits to Claude for analysis 4. 392 392 + Saves changelog entries back to .changes/<repo>-daily.json 358 393 359 394 Also generates an aggregated DAILY-CHANGES.md at the monorepo root. 360 395 Repositories with no user-facing changes will have blank entries. ··· 368 403 @param clock Eio clock for time operations 369 404 @param package Optional specific repository to process 370 405 @param days Number of past days to analyze (default: 1) 371 371 - @param history Number of recent days to include in DAILY-CHANGES.md (default: 30) 406 406 + @param history 407 407 + Number of recent days to include in DAILY-CHANGES.md (default: 30) 372 408 @param dry_run If true, preview changes without writing files 373 373 - @param aggregate If true, also generate .changes/YYYYMMDD.json aggregated file *) 409 409 + @param aggregate 410 410 + If true, also generate .changes/YYYYMMDD.json aggregated file *) 411 411 + 412 412 + (** {1 Diff} *) 413 413 + 414 414 + (** A diff entry for a single repository showing commits from a verse member. *) 415 415 + type diff_entry = { 416 416 + repo_name : string; 417 417 + handle : string; 418 418 + relationship : Forks.relationship; 419 419 + commits : Git.log_entry list; 420 420 + patches : (string * string) list; (** hash -> patch content *) 421 421 + } 422 422 + 423 423 + (** Result of computing diffs for repos needing attention. *) 424 424 + type diff_result = { 425 425 + entries : diff_entry list; 426 426 + forks : Forks.t; 427 427 + } 428 428 + 429 429 + val pp_diff_entry : show_patch:bool -> diff_entry Fmt.t 430 430 + (** [pp_diff_entry ~show_patch] formats a single diff entry. 431 431 + If [show_patch] is true, includes the patch content for each commit. *) 432 432 + 433 433 + val pp_diff_result : show_patch:bool -> diff_result Fmt.t 434 434 + (** [pp_diff_result ~show_patch] formats the full diff result. *) 435 435 + 436 436 + val is_commit_sha : string -> bool 437 437 + (** [is_commit_sha s] returns true if [s] looks like a git commit hash 438 438 + (7+ hexadecimal characters). *) 439 439 + 440 440 + val diff : 441 441 + proc:_ Eio.Process.mgr -> 442 442 + fs:Eio.Fs.dir_ty Eio.Path.t -> 443 443 + config:Config.t -> 444 444 + verse_config:Verse_config.t -> 445 445 + ?repo:string -> 446 446 + ?refresh:bool -> 447 447 + ?patch:bool -> 448 448 + unit -> 449 449 + diff_result 450 450 + (** [diff ~proc ~fs ~config ~verse_config ?repo ?refresh ?patch ()] computes and displays diffs 451 451 + for repositories that need attention from verse members. 452 452 + 453 453 + For each repository where a verse member is ahead (I_am_behind or Diverged), 454 454 + retrieves the commit log showing what commits they have that you don't. 455 455 + 456 456 + Remote fetches are cached for 1 hour. Use [~refresh:true] to force fresh 457 457 + fetches from all remotes. 458 458 + 459 459 + @param proc Eio process manager 460 460 + @param fs Eio filesystem 461 461 + @param config Monopam configuration 462 462 + @param verse_config Verse configuration 463 463 + @param repo Optional specific repository to show diff for 464 464 + @param refresh If true, force fresh fetches ignoring cache (default: false) 465 465 + @param patch If true, fetch and include patch content for each commit (default: false) *) 466 466 + 467 467 + (** Result of looking up a specific commit *) 468 468 + type commit_info = { 469 469 + commit_repo : string; 470 470 + commit_handle : string; 471 471 + commit_hash : string; 472 472 + commit_subject : string; 473 473 + commit_author : string; 474 474 + commit_patch : string; 475 475 + } 476 476 + 477 477 + val diff_show_commit : 478 478 + proc:_ Eio.Process.mgr -> 479 479 + fs:Eio.Fs.dir_ty Eio.Path.t -> 480 480 + config:Config.t -> 481 481 + verse_config:Verse_config.t -> 482 482 + sha:string -> 483 483 + ?refresh:bool -> 484 484 + unit -> 485 485 + commit_info option 486 486 + (** [diff_show_commit ~proc ~fs ~config ~verse_config ~sha ?refresh ()] finds and shows 487 487 + the patch for a specific commit SHA from the diff output. 488 488 + 489 489 + Searches through all repos with actionable verse sources to find a commit 490 490 + matching the given SHA prefix. Returns [Some commit_info] if found, [None] otherwise. 491 491 + 492 492 + @param sha Commit SHA prefix (7+ characters) to look up *) 493 493 + 494 494 + (** {1 Pull from Verse Members} *) 495 495 + 496 496 + (** Result of pulling from a handle. *) 497 497 + type handle_pull_result = { 498 498 + repos_pulled : (string * int) list; (** (repo_name, commit_count) for each repo pulled *) 499 499 + repos_skipped : string list; (** Repos skipped (already in sync or no checkout) *) 500 500 + repos_failed : (string * string) list; (** (repo_name, error_message) for failures *) 501 501 + } 502 502 + 503 503 + val pp_handle_pull_result : handle_pull_result Fmt.t 504 504 + (** [pp_handle_pull_result] formats a pull result. *) 505 505 + 506 506 + val pull_from_handle : 507 507 + proc:_ Eio.Process.mgr -> 508 508 + fs:Eio.Fs.dir_ty Eio.Path.t -> 509 509 + config:Config.t -> 510 510 + verse_config:Verse_config.t -> 511 511 + handle:string -> 512 512 + ?repo:string -> 513 513 + ?refresh:bool -> 514 514 + unit -> 515 515 + (handle_pull_result, error) result 516 516 + (** [pull_from_handle ~proc ~fs ~config ~verse_config ~handle ?repo ?refresh ()] 517 517 + pulls commits from a verse member's forks into your local checkouts. 518 518 + 519 519 + For each repository where the handle has commits you don't have: 520 520 + 1. Merges their commits into your checkout's main branch 521 521 + 2. The changes are then ready to be synced to the monorepo via [sync] 522 522 + 523 523 + If [repo] is specified, only pulls from that repository. 524 524 + Otherwise, pulls from all repositories where the handle is ahead. 525 525 + 526 526 + @param handle The verse member handle (e.g., "avsm.bsky.social") 527 527 + @param repo Optional specific repository to pull from 528 528 + @param refresh If true, force fresh fetches ignoring cache (default: false) *) 529 529 + 530 530 + (** {1 Cherry-pick} *) 531 531 + 532 532 + (** Result of cherry-picking a commit. *) 533 533 + type cherrypick_result = { 534 534 + repo_name : string; 535 535 + commit_hash : string; 536 536 + commit_subject : string; 537 537 + } 538 538 + 539 539 + val pp_cherrypick_result : cherrypick_result Fmt.t 540 540 + (** [pp_cherrypick_result] formats a cherry-pick result. *) 541 541 + 542 542 + val cherrypick : 543 543 + proc:_ Eio.Process.mgr -> 544 544 + fs:Eio.Fs.dir_ty Eio.Path.t -> 545 545 + config:Config.t -> 546 546 + verse_config:Verse_config.t -> 547 547 + sha:string -> 548 548 + ?refresh:bool -> 549 549 + unit -> 550 550 + (cherrypick_result, error) result 551 551 + (** [cherrypick ~proc ~fs ~config ~verse_config ~sha ?refresh ()] 552 552 + applies a specific commit from a verse member's fork to your local checkout. 553 553 + 554 554 + Finds the commit in the verse diff output and cherry-picks it into the 555 555 + appropriate local checkout. The changes are then ready to be synced to 556 556 + the monorepo via [sync]. 557 557 + 558 558 + @param sha Commit SHA prefix (7+ characters) to cherry-pick 559 559 + @param refresh If true, force fresh fetches ignoring cache (default: false) *)

+11 -42

lib/opam_repo.ml

reviewed

··· 31 31 | true -> String.sub url 4 (String.length url - 4) 32 32 | false -> url 33 33 in 34 34 - let uri = Uri.of_string url in 35 35 - (* Strip fragment from dev-repo URL - branch comes from url field *) 36 36 - Uri.with_fragment uri None 37 37 - 38 38 - (** Extract branch from a URL string with optional #branch fragment *) 39 39 - let extract_branch_from_url url = 40 40 - let url = 41 41 - match String.starts_with ~prefix:"git+" url with 42 42 - | true -> String.sub url 4 (String.length url - 4) 43 43 - | false -> url 44 44 - in 45 45 - Uri.fragment (Uri.of_string url) 34 34 + Uri.of_string url 46 35 47 36 module OP = OpamParserTypes.FullPos 48 37 ··· 58 47 | _ -> None) 59 48 items 60 49 61 61 - (** Find the 'src' field inside a 'url' section *) 62 62 - let find_url_src (items : OP.opamfile_item list) : string option = 63 63 - List.find_map 64 64 - (fun (item : OP.opamfile_item) -> 65 65 - match item.pelem with 66 66 - | OP.Section sec when sec.section_kind.pelem = "url" -> 67 67 - (* Look for src field inside the section *) 68 68 - List.find_map 69 69 - (fun (inner : OP.opamfile_item) -> 70 70 - match inner.pelem with 71 71 - | OP.Variable (name, value) when name.pelem = "src" -> 72 72 - extract_string_value value 73 73 - | _ -> None) 74 74 - sec.section_items.pelem 75 75 - | _ -> None) 76 76 - items 77 77 - 78 50 (** Extract package name from a dependency formula value. 79 51 Handles cases like: 80 52 - "pkgname" ··· 87 59 | OP.Option (inner, _) -> extract_dep_name inner 88 60 | _ -> None 89 61 90 90 - (** Extract all dependency package names from a depends value. 91 91 - The depends field is a list of package formulas. *) 62 62 + (** Extract all dependency package names from a depends value. The depends field 63 63 + is a list of package formulas. *) 92 64 let extract_depends_list (v : OP.value) : string list = 93 65 match v.pelem with 94 94 - | OP.List { pelem = items; _ } -> 95 95 - List.filter_map extract_dep_name items 96 96 - | _ -> ( 97 97 - match extract_dep_name v with Some s -> [ s ] | None -> []) 66 66 + | OP.List { pelem = items; _ } -> List.filter_map extract_dep_name items 67 67 + | _ -> ( match extract_dep_name v with Some s -> [ s ] | None -> []) 98 68 99 69 let find_depends (items : OP.opamfile_item list) : string list = 100 70 List.find_map ··· 144 114 if not (is_git_url url) then Error (Not_git_remote (name, url)) 145 115 else 146 116 let dev_repo = normalize_git_url url in 147 147 - (* Extract branch from url field's src, not from dev-repo *) 148 148 - let branch = Option.bind (find_url_src opamfile.file_contents) extract_branch_from_url in 149 117 let depends = find_depends opamfile.file_contents in 150 118 let synopsis = find_synopsis opamfile.file_contents in 151 151 - Ok (Package.create ~name ~version ~dev_repo ?branch ~depends ?synopsis ()) 119 119 + Ok (Package.create ~name ~version ~dev_repo ~depends ?synopsis ()) 152 120 with 153 121 | Eio.Io _ as e -> Error (Io_error (Printexc.to_string e)) 154 122 | exn -> Error (Parse_error (path_str, Printexc.to_string exn))) ··· 193 161 let _, errors = scan_all ~fs repo_path in 194 162 errors 195 163 196 196 - (** Scan a directory for .opam files and extract all dependencies. 197 197 - This is used to find dependencies from monorepo subtree directories, 198 198 - where multiple .opam files may exist that aren't in the opam overlay. *) 164 164 + (** Scan a directory for .opam files and extract all dependencies. This is used 165 165 + to find dependencies from monorepo subtree directories, where multiple .opam 166 166 + files may exist that aren't in the opam overlay. *) 199 167 let scan_opam_files_for_deps ~fs dir_path = 200 168 let eio_path = Eio.Path.(fs / Fpath.to_string dir_path) in 201 169 try ··· 209 177 try 210 178 let content = Eio.Path.load opam_path in 211 179 let opamfile = 212 212 - OpamParser.FullPos.string content (Fpath.to_string dir_path ^ "/" ^ opam_file) 180 180 + OpamParser.FullPos.string content 181 181 + (Fpath.to_string dir_path ^ "/" ^ opam_file) 213 182 in 214 183 find_depends opamfile.file_contents 215 184 with _ -> [])

+4 -9

lib/opam_repo.mli

reviewed

··· 71 71 72 72 val normalize_git_url : string -> Uri.t 73 73 (** [normalize_git_url url] normalizes a git URL by removing the "git+" prefix 74 74 - and any fragment (branch) if present. 74 74 + if present. 75 75 76 76 - For example, "git+https://example.com/repo.git#main" becomes 76 76 + For example, "git+https://example.com/repo.git" becomes 77 77 "https://example.com/repo.git". *) 78 78 79 79 - val extract_branch_from_url : string -> string option 80 80 - (** [extract_branch_from_url url] extracts the branch from a URL fragment. 81 81 - 82 82 - For example, "git+https://example.com/repo.git#main" returns [Some "main"]. *) 83 83 - 84 79 val scan_opam_files_for_deps : fs:_ Eio.Path.t -> Fpath.t -> string list 85 80 (** [scan_opam_files_for_deps ~fs dir_path] scans a directory for .opam files 86 81 and extracts all dependencies from them. 87 82 88 88 - This is used to find dependencies from monorepo subtree directories, 89 89 - where multiple .opam files may exist that aren't in the opam overlay. 83 83 + This is used to find dependencies from monorepo subtree directories, where 84 84 + multiple .opam files may exist that aren't in the opam overlay. 90 85 91 86 @param fs Eio filesystem capability 92 87 @param dir_path Path to the directory to scan

+78

lib/opam_transform.ml

reviewed

··· 1 1 + (** Transform dune-generated opam files for opam-repo overlay. *) 2 2 + 3 3 + (** Remove the "generated by dune" comment from the first line *) 4 4 + let strip_dune_comment content = 5 5 + let lines = String.split_on_char '\n' content in 6 6 + match lines with 7 7 + | first :: rest 8 8 + when String.starts_with ~prefix:"# This file is generated by dune" 9 9 + (String.trim first) -> 10 10 + String.concat "\n" rest 11 11 + | _ -> content 12 12 + 13 13 + (** Remove existing dev-repo line if present *) 14 14 + let remove_dev_repo_line content = 15 15 + let lines = String.split_on_char '\n' content in 16 16 + let lines = 17 17 + List.filter 18 18 + (fun line -> 19 19 + let trimmed = String.trim line in 20 20 + not (String.starts_with ~prefix:"dev-repo:" trimmed)) 21 21 + lines 22 22 + in 23 23 + String.concat "\n" lines 24 24 + 25 25 + (** Remove existing url { ... } section if present *) 26 26 + let remove_url_section content = 27 27 + let lines = String.split_on_char '\n' content in 28 28 + let rec process lines in_url_block acc = 29 29 + match lines with 30 30 + | [] -> List.rev acc 31 31 + | line :: rest -> 32 32 + let trimmed = String.trim line in 33 33 + if in_url_block then 34 34 + (* Inside url { ... }, skip until we see } *) 35 35 + if String.starts_with ~prefix:"}" trimmed then 36 36 + process rest false acc 37 37 + else process rest true acc 38 38 + else if trimmed = "url {" || String.starts_with ~prefix:"url {" trimmed 39 39 + then 40 40 + (* Start of url block *) 41 41 + if String.ends_with ~suffix:"}" trimmed then 42 42 + (* Single-line url block, skip it *) 43 43 + process rest false acc 44 44 + else process rest true acc 45 45 + else process rest false (line :: acc) 46 46 + in 47 47 + String.concat "\n" (process lines false []) 48 48 + 49 49 + (** Trim trailing blank lines and ensure single trailing newline *) 50 50 + let normalize_ending content = 51 51 + let lines = String.split_on_char '\n' content in 52 52 + let rec trim_trailing = function 53 53 + | [] -> [] 54 54 + | [ "" ] -> [] 55 55 + | "" :: rest -> ( 56 56 + match trim_trailing rest with [] -> [] | trimmed -> "" :: trimmed) 57 57 + | x :: rest -> x :: trim_trailing rest 58 58 + in 59 59 + let lines = List.rev (trim_trailing (List.rev lines)) in 60 60 + String.concat "\n" lines 61 61 + 62 62 + let transform ~content ~dev_repo ~url_src = 63 63 + (* Step 1: Strip the dune comment *) 64 64 + let content = strip_dune_comment content in 65 65 + 66 66 + (* Step 2: Remove any existing dev-repo and url sections *) 67 67 + let content = remove_dev_repo_line content in 68 68 + let content = remove_url_section content in 69 69 + 70 70 + (* Step 3: Normalize ending *) 71 71 + let content = normalize_ending content in 72 72 + 73 73 + (* Step 4: Append dev-repo and url section *) 74 74 + let dev_repo_line = Printf.sprintf {|dev-repo: "%s"|} dev_repo in 75 75 + let url_section = 76 76 + Printf.sprintf "url {\n src: \"%s\"\n}" url_src 77 77 + in 78 78 + content ^ "\n" ^ dev_repo_line ^ "\n" ^ url_section ^ "\n"

+18

lib/opam_transform.mli

reviewed

··· 1 1 + (** Transform dune-generated opam files for opam-repo overlay. 2 2 + 3 3 + Dune generates .opam files from dune-project, but these need to be 4 4 + transformed before being placed in the opam-repo overlay: 5 5 + - Remove the "generated by dune" comment 6 6 + - Add dev-repo field with the git repository URL 7 7 + - Add url section with source URL and branch *) 8 8 + 9 9 + val transform : content:string -> dev_repo:string -> url_src:string -> string 10 10 + (** [transform ~content ~dev_repo ~url_src] transforms a dune-generated opam file. 11 11 + 12 12 + - Removes the "# This file is generated by dune" comment if present 13 13 + - Adds or replaces the [dev-repo] field with [dev_repo] 14 14 + - Adds or replaces the [url { src: "..." }] section with [url_src] 15 15 + 16 16 + @param content The original opam file content 17 17 + @param dev_repo The dev-repo URL (e.g., "git+https://github.com/user/repo.git") 18 18 + @param url_src The url src URL with branch (e.g., "git+https://...#main") *)

+4 -2

lib/package.mli

reviewed

··· 20 20 ?synopsis:string -> 21 21 unit -> 22 22 t 23 23 - (** [create ~name ~version ~dev_repo ?branch ?depends ?synopsis ()] creates a new package. 23 23 + (** [create ~name ~version ~dev_repo ?branch ?depends ?synopsis ()] creates a 24 24 + new package. 24 25 25 26 @param name The opam package name 26 27 @param version The package version (e.g., "dev") ··· 44 45 (** [branch t] returns the branch to track, if explicitly set. *) 45 46 46 47 val depends : t -> string list 47 47 - (** [depends t] returns the list of opam package names this package depends on. *) 48 48 + (** [depends t] returns the list of opam package names this package depends on. 49 49 + *) 48 50 49 51 val synopsis : t -> string option 50 52 (** [synopsis t] returns the short description of the package, if any. *)

+535

lib/site.ml

reviewed

··· 1 1 + (** Generate a static HTML site representing the monoverse map. *) 2 2 + 3 3 + (** Information about a package in the verse *) 4 4 + type pkg_info = { 5 5 + name : string; 6 6 + synopsis : string option; 7 7 + repo_name : string; 8 8 + dev_repo : string; (** Upstream git URL *) 9 9 + owners : string list; (** List of handles that have this package *) 10 10 + depends : string list; (** Package dependencies *) 11 11 + } 12 12 + 13 13 + (** Information about a repository (group of packages) *) 14 14 + type repo_info = { 15 15 + ri_name : string; 16 16 + ri_dev_repo : string; 17 17 + ri_packages : pkg_info list; 18 18 + ri_owners : string list; (** All handles that have any package from this repo *) 19 19 + ri_fork_status : (string * Forks.relationship) list; (** (handle, relationship) *) 20 20 + ri_dep_count : int; (** Number of dependencies (for sorting) *) 21 21 + } 22 22 + 23 23 + (** Information about a verse member *) 24 24 + type member_info = { 25 25 + handle : string; 26 26 + display_name : string; (** Name to display (from registry or handle) *) 27 27 + monorepo_url : string; 28 28 + opam_url : string; 29 29 + package_count : int; 30 30 + unique_packages : string list; (** Packages unique to this member *) 31 31 + } 32 32 + 33 33 + (** Aggregated site data *) 34 34 + type site_data = { 35 35 + local_handle : string; 36 36 + registry_name : string; 37 37 + registry_description : string option; 38 38 + members : member_info list; 39 39 + common_repos : repo_info list; (** Repos that exist in multiple members *) 40 40 + unique_repos : repo_info list; (** Repos unique to one member *) 41 41 + all_packages : pkg_info list; (** All packages *) 42 42 + } 43 43 + 44 44 + (** Scan a member's opam repo and return package info *) 45 45 + let scan_member_packages ~fs opam_repo_path = 46 46 + let pkgs, _errors = Opam_repo.scan_all ~fs opam_repo_path in 47 47 + List.map (fun pkg -> 48 48 + { 49 49 + name = Package.name pkg; 50 50 + synopsis = Package.synopsis pkg; 51 51 + repo_name = Package.repo_name pkg; 52 52 + dev_repo = Uri.to_string (Package.dev_repo pkg); 53 53 + owners = []; 54 54 + depends = Package.depends pkg; 55 55 + } 56 56 + ) pkgs 57 57 + 58 58 + (** Check if a directory exists *) 59 59 + let dir_exists ~fs path = 60 60 + let eio_path = Eio.Path.(fs / Fpath.to_string path) in 61 61 + match Eio.Path.kind ~follow:true eio_path with 62 62 + | `Directory -> true 63 63 + | _ -> false 64 64 + | exception _ -> false 65 65 + 66 66 + (** Collect site data from the workspace *) 67 67 + let collect_data ~fs ~config ?forks ~registry () = 68 68 + let local_handle = Verse_config.handle config in 69 69 + let local_opam_repo = Verse_config.opam_repo_path config in 70 70 + let verse_path = Verse_config.verse_path config in 71 71 + 72 72 + (* Scan local packages *) 73 73 + let local_pkgs = 74 74 + if dir_exists ~fs local_opam_repo then 75 75 + scan_member_packages ~fs local_opam_repo 76 76 + else [] 77 77 + in 78 78 + 79 79 + (* Build a map: package name -> list of (handle, pkg_info) *) 80 80 + let pkg_map : (string, (string * pkg_info) list) Hashtbl.t = Hashtbl.create 256 in 81 81 + 82 82 + (* Add local packages *) 83 83 + List.iter (fun pkg -> 84 84 + let existing = try Hashtbl.find pkg_map pkg.name with Not_found -> [] in 85 85 + Hashtbl.replace pkg_map pkg.name ((local_handle, pkg) :: existing) 86 86 + ) local_pkgs; 87 87 + 88 88 + let registry_name = registry.Verse_registry.name in 89 89 + let registry_description = registry.Verse_registry.description in 90 90 + 91 91 + (* Build handle -> display name lookup *) 92 92 + let handle_to_name = Hashtbl.create 16 in 93 93 + List.iter (fun (m : Verse_registry.member) -> 94 94 + let display = match m.name with Some n -> n | None -> m.handle in 95 95 + Hashtbl.replace handle_to_name m.handle display 96 96 + ) registry.Verse_registry.members; 97 97 + 98 98 + (* Get tracked handles from verse directory, excluding local handle *) 99 99 + let tracked_handles = 100 100 + if dir_exists ~fs verse_path then 101 101 + let eio_path = Eio.Path.(fs / Fpath.to_string verse_path) in 102 102 + try 103 103 + Eio.Path.read_dir eio_path 104 104 + |> List.filter (fun name -> 105 105 + not (String.ends_with ~suffix:"-opam" name) && 106 106 + name <> local_handle && 107 107 + dir_exists ~fs Fpath.(verse_path / name)) 108 108 + with Eio.Io _ -> [] 109 109 + else [] 110 110 + in 111 111 + 112 112 + (* Scan each tracked member's opam repo *) 113 113 + let member_infos = 114 114 + List.filter_map (fun handle -> 115 115 + let opam_path = Fpath.(verse_path / (handle ^ "-opam")) in 116 116 + if dir_exists ~fs opam_path then begin 117 117 + let pkgs = scan_member_packages ~fs opam_path in 118 118 + (* Add to package map *) 119 119 + List.iter (fun pkg -> 120 120 + let existing = try Hashtbl.find pkg_map pkg.name with Not_found -> [] in 121 121 + Hashtbl.replace pkg_map pkg.name ((handle, pkg) :: existing) 122 122 + ) pkgs; 123 123 + (* Look up member in registry for URLs *) 124 124 + let member = Verse_registry.find_member registry ~handle in 125 125 + let display_name = 126 126 + try Hashtbl.find handle_to_name handle 127 127 + with Not_found -> handle 128 128 + in 129 129 + Some { 130 130 + handle; 131 131 + display_name; 132 132 + monorepo_url = (match member with Some m -> m.monorepo | None -> ""); 133 133 + opam_url = (match member with Some m -> m.opamrepo | None -> ""); 134 134 + package_count = List.length pkgs; 135 135 + unique_packages = []; (* Will be filled in later *) 136 136 + } 137 137 + end else None 138 138 + ) tracked_handles 139 139 + in 140 140 + 141 141 + (* Add local member info *) 142 142 + let local_member = 143 143 + let member = Verse_registry.find_member registry ~handle:local_handle in 144 144 + let display_name = 145 145 + try Hashtbl.find handle_to_name local_handle 146 146 + with Not_found -> local_handle 147 147 + in 148 148 + { 149 149 + handle = local_handle; 150 150 + display_name; 151 151 + monorepo_url = (match member with Some m -> m.monorepo | None -> ""); 152 152 + opam_url = (match member with Some m -> m.opamrepo | None -> ""); 153 153 + package_count = List.length local_pkgs; 154 154 + unique_packages = []; 155 155 + } 156 156 + in 157 157 + 158 158 + (* Build final package list with owners *) 159 159 + let all_packages = 160 160 + Hashtbl.fold (fun _name entries acc -> 161 161 + match entries with 162 162 + | [] -> acc 163 163 + | (_, pkg) :: _ as all -> 164 164 + let owners = List.map fst all in 165 165 + (* Pick the best synopsis (first non-None) *) 166 166 + let synopsis = 167 167 + List.find_map (fun (_, p) -> p.synopsis) all 168 168 + in 169 169 + (* Merge depends from all sources *) 170 170 + let depends = 171 171 + List.concat_map (fun (_, p) -> p.depends) all 172 172 + |> List.sort_uniq String.compare 173 173 + in 174 174 + { pkg with owners; synopsis; depends } :: acc 175 175 + ) pkg_map [] 176 176 + |> List.sort (fun a b -> String.compare a.name b.name) 177 177 + in 178 178 + 179 179 + (* Build set of all package names for dependency counting *) 180 180 + let all_pkg_names = 181 181 + List.fold_left (fun s p -> Hashtbl.replace s p.name (); s) 182 182 + (Hashtbl.create 256) all_packages 183 183 + in 184 184 + 185 185 + (* Group packages by repo *) 186 186 + let repos_map : (string, pkg_info list) Hashtbl.t = Hashtbl.create 64 in 187 187 + List.iter (fun (pkg : pkg_info) -> 188 188 + let existing = try Hashtbl.find repos_map pkg.repo_name with Not_found -> [] in 189 189 + Hashtbl.replace repos_map pkg.repo_name (pkg :: existing) 190 190 + ) all_packages; 191 191 + 192 192 + (* Build forks status lookup from forks data if provided *) 193 193 + let forks_by_repo : (string, (string * Forks.relationship) list) Hashtbl.t = Hashtbl.create 64 in 194 194 + (match forks with 195 195 + | Some f -> 196 196 + List.iter (fun (ra : Forks.repo_analysis) -> 197 197 + let statuses = List.map (fun (h, _src, rel) -> (h, rel)) ra.verse_sources in 198 198 + Hashtbl.replace forks_by_repo ra.repo_name statuses 199 199 + ) f.Forks.repos 200 200 + | None -> ()); 201 201 + 202 202 + (* Build repo_info list with dependency counts *) 203 203 + let all_repos = 204 204 + Hashtbl.fold (fun repo_name pkgs acc -> 205 205 + let dev_repo = (List.hd pkgs).dev_repo in 206 206 + let owners = 207 207 + List.sort_uniq String.compare (List.concat_map (fun (p : pkg_info) -> p.owners) pkgs) 208 208 + in 209 209 + let fork_status = 210 210 + try Hashtbl.find forks_by_repo repo_name with Not_found -> [] 211 211 + in 212 212 + (* Count dependencies that are in our package set *) 213 213 + let dep_count = 214 214 + List.concat_map (fun (p : pkg_info) -> p.depends) pkgs 215 215 + |> List.filter (fun d -> Hashtbl.mem all_pkg_names d) 216 216 + |> List.sort_uniq String.compare 217 217 + |> List.length 218 218 + in 219 219 + { ri_name = repo_name; 220 220 + ri_dev_repo = dev_repo; 221 221 + ri_packages = List.sort (fun a b -> String.compare a.name b.name) pkgs; 222 222 + ri_owners = owners; 223 223 + ri_fork_status = fork_status; 224 224 + ri_dep_count = dep_count } :: acc 225 225 + ) repos_map [] 226 226 + (* Sort by dependency count descending (apps with most deps first), then by name *) 227 227 + |> List.sort (fun a b -> 228 228 + let cmp = compare b.ri_dep_count a.ri_dep_count in 229 229 + if cmp <> 0 then cmp else String.compare a.ri_name b.ri_name) 230 230 + in 231 231 + 232 232 + (* Separate common and unique repos *) 233 233 + let common_repos = List.filter (fun r -> List.length r.ri_owners > 1) all_repos in 234 234 + let unique_repos = List.filter (fun r -> List.length r.ri_owners = 1) all_repos in 235 235 + 236 236 + (* Compute unique packages per member *) 237 237 + let unique_by_handle = Hashtbl.create 32 in 238 238 + List.iter (fun (pkg : pkg_info) -> 239 239 + if List.length pkg.owners = 1 then begin 240 240 + let handle = List.hd pkg.owners in 241 241 + let existing = try Hashtbl.find unique_by_handle handle with Not_found -> [] in 242 242 + Hashtbl.replace unique_by_handle handle (pkg.name :: existing) 243 243 + end 244 244 + ) all_packages; 245 245 + 246 246 + (* Update member infos with unique packages *) 247 247 + let update_member m = 248 248 + let unique = try Hashtbl.find unique_by_handle m.handle with Not_found -> [] in 249 249 + { m with unique_packages = List.sort String.compare unique } 250 250 + in 251 251 + 252 252 + let all_members = local_member :: member_infos in 253 253 + let members = List.map update_member all_members in 254 254 + 255 255 + { local_handle; registry_name; registry_description; members; common_repos; unique_repos; all_packages } 256 256 + 257 257 + (** Escape HTML special characters *) 258 258 + let html_escape s = 259 259 + let buf = Buffer.create (String.length s) in 260 260 + String.iter (function 261 261 + | '<' -> Buffer.add_string buf "&lt;" 262 262 + | '>' -> Buffer.add_string buf "&gt;" 263 263 + | '&' -> Buffer.add_string buf "&amp;" 264 264 + | '"' -> Buffer.add_string buf "&quot;" 265 265 + | c -> Buffer.add_char buf c 266 266 + ) s; 267 267 + Buffer.contents buf 268 268 + 269 269 + (** External link SVG icon *) 270 270 + let external_link_icon = 271 271 + {|<svg class="ext-icon" viewBox="0 0 12 12" fill="none" stroke="currentColor" stroke-width="1.5"><path d="M3.5 3H9V8.5M9 3L3 9"/></svg>|} 272 272 + 273 273 + (** Format fork relationship as short string *) 274 274 + let format_relationship = function 275 275 + | Forks.Same_url -> "=" 276 276 + | Forks.Same_commit -> "sync" 277 277 + | Forks.I_am_ahead n -> Printf.sprintf "+%d" n 278 278 + | Forks.I_am_behind n -> Printf.sprintf "-%d" n 279 279 + | Forks.Diverged { my_ahead; their_ahead; _ } -> Printf.sprintf "+%d/-%d" my_ahead their_ahead 280 280 + | Forks.Unrelated -> "unrel" 281 281 + | Forks.Not_fetched -> "?" 282 282 + 283 283 + (** Generate HTML from site data *) 284 284 + let generate_html data = 285 285 + let buf = Buffer.create 16384 in 286 286 + let add = Buffer.add_string buf in 287 287 + 288 288 + (* Build member lookups *) 289 289 + let member_urls = Hashtbl.create 16 in 290 290 + let member_names = Hashtbl.create 16 in 291 291 + List.iter (fun m -> 292 292 + Hashtbl.replace member_urls m.handle (m.monorepo_url, m.opam_url); 293 293 + Hashtbl.replace member_names m.handle m.display_name 294 294 + ) data.members; 295 295 + 296 296 + (* Helper to get display name for handle *) 297 297 + let get_name handle = 298 298 + try Hashtbl.find member_names handle with Not_found -> handle 299 299 + in 300 300 + 301 301 + add {|<!DOCTYPE html> 302 302 + <html lang="en"> 303 303 + <head> 304 304 + <meta charset="UTF-8"> 305 305 + <meta name="viewport" content="width=device-width, initial-scale=1.0"> 306 306 + <title>|}; 307 307 + add (html_escape data.registry_name); 308 308 + add {|</title> 309 309 + <style> 310 310 + * { margin: 0; padding: 0; box-sizing: border-box; } 311 311 + body { font: 10pt/1.4 -apple-system, BlinkMacSystemFont, "Segoe UI", Roboto, sans-serif; color: #333; max-width: 900px; margin: 0 auto; padding: 12px; } 312 312 + h1 { font-size: 14pt; font-weight: 600; margin-bottom: 4px; } 313 313 + .subtitle { font-size: 9pt; color: #666; margin-bottom: 12px; border-bottom: 1px solid #ddd; padding-bottom: 8px; } 314 314 + h2 { font-size: 11pt; font-weight: 600; margin: 16px 0 8px; color: #444; } 315 315 + h3 { font-size: 10pt; font-weight: 600; margin: 12px 0 6px; color: #555; } 316 316 + a { color: #0066cc; text-decoration: none; } 317 317 + a:hover { text-decoration: underline; } 318 318 + a.ext { color: #0088aa; } 319 319 + a.ext:hover { color: #006688; } 320 320 + .ext-icon { width: 10px; height: 10px; margin-left: 2px; vertical-align: baseline; position: relative; top: 1px; } 321 321 + .members { display: grid; grid-template-columns: repeat(auto-fill, minmax(200px, 1fr)); gap: 8px; margin-bottom: 16px; } 322 322 + .member { background: #f8f8f8; padding: 8px; border-radius: 4px; border: 1px solid #e0e0e0; } 323 323 + .member-name { font-weight: 600; margin-bottom: 2px; } 324 324 + .member-handle { font-size: 8pt; color: #888; margin-bottom: 4px; } 325 325 + .member-stats { font-size: 9pt; color: #666; } 326 326 + .member-links { font-size: 9pt; margin-top: 4px; } 327 327 + .member-links a { margin-right: 8px; } 328 328 + .section { margin-bottom: 20px; } 329 329 + .summary { background: #fafafa; border: 1px solid #e8e8e8; border-radius: 4px; padding: 12px; margin-bottom: 16px; } 330 330 + .summary-title { font-weight: 600; margin-bottom: 8px; } 331 331 + .summary-list { font-size: 9pt; color: #555; line-height: 1.6; } 332 332 + .summary-item { display: inline-block; background: #fff; border: 1px solid #ddd; padding: 1px 6px; border-radius: 3px; margin: 2px 2px; } 333 333 + .summary-item a { color: #333; } 334 334 + .repo { margin-bottom: 12px; padding: 8px; background: #fafafa; border-radius: 4px; } 335 335 + .repo-header { display: flex; align-items: baseline; gap: 8px; margin-bottom: 4px; } 336 336 + .repo-name { font-weight: 600; } 337 337 + .repo-name a { color: #333; } 338 338 + .repo-packages { font-size: 9pt; color: #666; margin-bottom: 4px; } 339 339 + .pkg-list { list-style: none; margin: 4px 0 0 0; padding: 0; } 340 340 + .pkg-list li { padding: 1px 0; color: #555; font-size: 8pt; } 341 341 + .pkg-list li::before { content: "-"; color: #999; margin-right: 6px; } 342 342 + .pkg-list b { font-weight: 500; color: #444; } 343 343 + .repo-forks { margin-top: 6px; } 344 344 + .repo-forks summary { font-size: 9pt; color: #666; cursor: pointer; } 345 345 + .repo-forks summary:hover { color: #444; } 346 346 + .fork-list { margin-top: 4px; font-size: 9pt; display: flex; flex-wrap: wrap; gap: 4px 12px; } 347 347 + .fork-item { color: #555; } 348 348 + .fork-item a { margin-left: 4px; } 349 349 + .fork-status { font-family: monospace; font-size: 8pt; padding: 1px 4px; border-radius: 2px; margin-left: 4px; } 350 350 + .fork-status.ahead { background: #e6f4ea; color: #137333; } 351 351 + .fork-status.behind { background: #fce8e6; color: #c5221f; } 352 352 + .fork-status.diverged { background: #fef7e0; color: #b06000; } 353 353 + .fork-status.sync { background: #e8f0fe; color: #1a73e8; } 354 354 + .unique-section { margin-top: 12px; } 355 355 + .unique-member { margin-bottom: 8px; } 356 356 + .unique-member-name { font-weight: 500; font-size: 9pt; color: #555; } 357 357 + .unique-list { font-size: 9pt; color: #666; margin-top: 2px; } 358 358 + .intro { background: #f0f7ff; border: 1px solid #d0e3f5; border-radius: 4px; padding: 10px 12px; margin-bottom: 16px; font-size: 9pt; line-height: 1.5; color: #444; } 359 359 + footer { margin-top: 20px; padding-top: 8px; border-top: 1px solid #ddd; font-size: 9pt; color: #888; } 360 360 + </style> 361 361 + </head> 362 362 + <body> 363 363 + |}; 364 364 + 365 365 + (* Title and description *) 366 366 + add (Printf.sprintf "<h1>%s</h1>\n" (html_escape data.registry_name)); 367 367 + (match data.registry_description with 368 368 + | Some desc -> add (Printf.sprintf "<div class=\"subtitle\">%s</div>\n" (html_escape desc)) 369 369 + | None -> add "<div class=\"subtitle\"></div>\n"); 370 370 + 371 371 + (* Intro section *) 372 372 + add {|<div class="intro"> 373 373 + This is an experiment in large-scale agentic coding using OCaml and OxCaml, where we're building environments to exchange vibe code at scale. 374 374 + Managed by <a class="ext" href="https://tangled.org/anil.recoil.org/monopam">monopam|}; add external_link_icon; add {|</a>, 375 375 + with the central registry at <a class="ext" href="https://tangled.org/eeg.cl.cam.ac.uk/opamverse">opamverse|}; add external_link_icon; add {|</a>. 376 376 + </div> 377 377 + |}; 378 378 + 379 379 + (* Members section *) 380 380 + add "<div class=\"section\">\n<h2>Members</h2>\n<div class=\"members\">\n"; 381 381 + List.iter (fun m -> 382 382 + add "<div class=\"member\">\n"; 383 383 + add (Printf.sprintf "<div class=\"member-name\"><a href=\"https://%s\">%s</a></div>\n" 384 384 + (html_escape m.handle) (html_escape m.display_name)); 385 385 + if m.display_name <> m.handle then 386 386 + add (Printf.sprintf "<div class=\"member-handle\">%s</div>\n" (html_escape m.handle)); 387 387 + add (Printf.sprintf "<div class=\"member-stats\">%d packages" m.package_count); 388 388 + if m.unique_packages <> [] then 389 389 + add (Printf.sprintf ", %d unique" (List.length m.unique_packages)); 390 390 + add "</div>\n"; 391 391 + if m.monorepo_url <> "" || m.opam_url <> "" then begin 392 392 + add "<div class=\"member-links\">"; 393 393 + if m.monorepo_url <> "" then 394 394 + add (Printf.sprintf "<a class=\"ext\" href=\"%s\">mono%s</a>" (html_escape m.monorepo_url) external_link_icon); 395 395 + if m.opam_url <> "" then 396 396 + add (Printf.sprintf "<a class=\"ext\" href=\"%s\">opam%s</a>" (html_escape m.opam_url) external_link_icon); 397 397 + add "</div>\n" 398 398 + end; 399 399 + add "</div>\n" 400 400 + ) data.members; 401 401 + add "</div>\n</div>\n"; 402 402 + 403 403 + (* Summary section *) 404 404 + add "<div class=\"section\">\n"; 405 405 + add "<div class=\"summary\">\n"; 406 406 + add (Printf.sprintf "<div class=\"summary-title\">Common Libraries (%d repos, %d packages)</div>\n" 407 407 + (List.length data.common_repos) 408 408 + (List.fold_left (fun acc r -> acc + List.length r.ri_packages) 0 data.common_repos)); 409 409 + add "<div class=\"summary-list\">\n"; 410 410 + List.iter (fun r -> 411 411 + add (Printf.sprintf "<span class=\"summary-item\"><a href=\"#%s\">%s</a> <span style=\"color:#888\">(%d)</span></span>\n" 412 412 + (html_escape r.ri_name) (html_escape r.ri_name) (List.length r.ri_packages)) 413 413 + ) data.common_repos; 414 414 + add "</div>\n</div>\n"; 415 415 + 416 416 + (* Member-specific summary *) 417 417 + let members_with_unique = List.filter (fun m -> m.unique_packages <> []) data.members in 418 418 + if members_with_unique <> [] then begin 419 419 + add "<div class=\"summary\">\n"; 420 420 + add "<div class=\"summary-title\">Member-Specific Packages</div>\n"; 421 421 + add "<div class=\"unique-section\">\n"; 422 422 + List.iter (fun m -> 423 423 + add "<div class=\"unique-member\">\n"; 424 424 + add (Printf.sprintf "<span class=\"unique-member-name\"><a href=\"https://%s\">%s</a>:</span> " 425 425 + (html_escape m.handle) (html_escape m.display_name)); 426 426 + add "<span class=\"unique-list\">"; 427 427 + add (String.concat ", " (List.map html_escape m.unique_packages)); 428 428 + add "</span>\n"; 429 429 + add "</div>\n" 430 430 + ) members_with_unique; 431 431 + add "</div>\n</div>\n" 432 432 + end; 433 433 + add "</div>\n"; 434 434 + 435 435 + (* Detailed repos section *) 436 436 + if data.common_repos <> [] then begin 437 437 + add "<div class=\"section\">\n<h2>Repository Details</h2>\n"; 438 438 + 439 439 + List.iter (fun r -> 440 440 + add (Printf.sprintf "<div class=\"repo\" id=\"%s\">\n" (html_escape r.ri_name)); 441 441 + add "<div class=\"repo-header\">"; 442 442 + add (Printf.sprintf "<span class=\"repo-name\"><a class=\"ext\" href=\"%s\">%s%s</a></span>" 443 443 + (html_escape r.ri_dev_repo) (html_escape r.ri_name) external_link_icon); 444 444 + add "</div>\n"; 445 445 + 446 446 + (* Packages list - compact with names *) 447 447 + add "<div class=\"repo-packages\">"; 448 448 + let pkg_names = List.map (fun (p : pkg_info) -> p.name) r.ri_packages in 449 449 + add (String.concat ", " (List.map html_escape pkg_names)); 450 450 + add "</div>\n"; 451 451 + 452 452 + (* Package descriptions as bullet list *) 453 453 + let pkg_descs = List.filter_map (fun (p : pkg_info) -> 454 454 + match p.synopsis with 455 455 + | Some s -> Some (p.name, s) 456 456 + | None -> None 457 457 + ) r.ri_packages in 458 458 + if pkg_descs <> [] then begin 459 459 + add "<ul class=\"pkg-list\">\n"; 460 460 + List.iter (fun (name, desc) -> 461 461 + add (Printf.sprintf "<li><b>%s</b>: %s</li>\n" (html_escape name) (html_escape desc)) 462 462 + ) pkg_descs; 463 463 + add "</ul>\n" 464 464 + end; 465 465 + 466 466 + (* Forks - at repo level with names *) 467 467 + if List.length r.ri_owners > 1 then begin 468 468 + let owner_links = List.map (fun h -> 469 469 + Printf.sprintf "<a href=\"https://%s\">%s</a>" (html_escape h) (html_escape (get_name h)) 470 470 + ) (List.sort String.compare r.ri_owners) in 471 471 + add "<details class=\"repo-forks\">\n"; 472 472 + add (Printf.sprintf "<summary>%d members (%s)</summary>\n" 473 473 + (List.length r.ri_owners) 474 474 + (String.concat ", " owner_links)); 475 475 + add "<div class=\"fork-list\">\n"; 476 476 + List.iter (fun handle -> 477 477 + let mono_url, _opam_url = 478 478 + try Hashtbl.find member_urls handle 479 479 + with Not_found -> ("", "") 480 480 + in 481 481 + add "<span class=\"fork-item\">"; 482 482 + add (Printf.sprintf "<a href=\"https://%s\">%s</a>" (html_escape handle) (html_escape (get_name handle))); 483 483 + (* Add status if available *) 484 484 + (match List.assoc_opt handle r.ri_fork_status with 485 485 + | Some rel -> 486 486 + let status_str = format_relationship rel in 487 487 + let status_class = 488 488 + match rel with 489 489 + | Forks.Same_url | Forks.Same_commit -> "sync" 490 490 + | Forks.I_am_ahead _ -> "ahead" 491 491 + | Forks.I_am_behind _ -> "behind" 492 492 + | Forks.Diverged _ -> "diverged" 493 493 + | _ -> "" 494 494 + in 495 495 + if status_class <> "" then 496 496 + add (Printf.sprintf "<span class=\"fork-status %s\">%s</span>" status_class status_str) 497 497 + else 498 498 + add (Printf.sprintf "<span class=\"fork-status\">%s</span>" status_str) 499 499 + | None -> ()); 500 500 + if mono_url <> "" then 501 501 + add (Printf.sprintf "<a class=\"ext\" href=\"%s/%s\">mono%s</a>" 502 502 + (html_escape mono_url) (html_escape r.ri_name) external_link_icon); 503 503 + add "</span>\n" 504 504 + ) (List.sort String.compare r.ri_owners); 505 505 + add "</div>\n</details>\n" 506 506 + end; 507 507 + 508 508 + add "</div>\n" 509 509 + ) data.common_repos; 510 510 + 511 511 + add "</div>\n" 512 512 + end; 513 513 + 514 514 + (* Footer with generation date *) 515 515 + let now = Unix.gettimeofday () in 516 516 + let tm = Unix.gmtime now in 517 517 + let date_str = Printf.sprintf "%04d-%02d-%02d" 518 518 + (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday in 519 519 + add (Printf.sprintf "<footer>Generated by monopam on %s | %d members | %d repos | %d packages</footer>\n" 520 520 + date_str (List.length data.members) (List.length data.common_repos + List.length data.unique_repos) (List.length data.all_packages)); 521 521 + 522 522 + add "</body>\n</html>\n"; 523 523 + Buffer.contents buf 524 524 + 525 525 + (** Generate the site and return the HTML content *) 526 526 + let generate ~fs ~config ?forks ~registry () = 527 527 + let data = collect_data ~fs ~config ?forks ~registry () in 528 528 + generate_html data 529 529 + 530 530 + (** Write the site to a file *) 531 531 + let write ~fs ~config ?forks ~registry ~output_path () = 532 532 + let html = generate ~fs ~config ?forks ~registry () in 533 533 + let eio_path = Eio.Path.(fs / Fpath.to_string output_path) in 534 534 + Eio.Path.save ~create:(`Or_truncate 0o644) eio_path html; 535 535 + Ok ()

+82

lib/site.mli

reviewed

··· 1 1 + (** Generate a static HTML site representing the monoverse map. 2 2 + 3 3 + The site command generates an index.html that shows: 4 4 + - All verse members with links to their repos 5 5 + - Summary of common libraries and member-specific packages 6 6 + - Detailed repository information with fork status *) 7 7 + 8 8 + (** {1 Types} *) 9 9 + 10 10 + (** Information about a package in the verse *) 11 11 + type pkg_info = { 12 12 + name : string; 13 13 + synopsis : string option; 14 14 + repo_name : string; 15 15 + dev_repo : string; (** Upstream git URL *) 16 16 + owners : string list; (** List of handles that have this package *) 17 17 + depends : string list; (** Package dependencies *) 18 18 + } 19 19 + 20 20 + (** Information about a repository (group of packages) *) 21 21 + type repo_info = { 22 22 + ri_name : string; 23 23 + ri_dev_repo : string; 24 24 + ri_packages : pkg_info list; 25 25 + ri_owners : string list; (** All handles that have any package from this repo *) 26 26 + ri_fork_status : (string * Forks.relationship) list; (** (handle, relationship) *) 27 27 + ri_dep_count : int; (** Number of dependencies (for sorting) *) 28 28 + } 29 29 + 30 30 + (** Information about a verse member *) 31 31 + type member_info = { 32 32 + handle : string; 33 33 + display_name : string; (** Name to display (from registry or handle) *) 34 34 + monorepo_url : string; 35 35 + opam_url : string; 36 36 + package_count : int; 37 37 + unique_packages : string list; (** Packages unique to this member *) 38 38 + } 39 39 + 40 40 + (** Aggregated site data *) 41 41 + type site_data = { 42 42 + local_handle : string; 43 43 + registry_name : string; 44 44 + registry_description : string option; 45 45 + members : member_info list; 46 46 + common_repos : repo_info list; (** Repos that exist in multiple members *) 47 47 + unique_repos : repo_info list; (** Repos unique to one member *) 48 48 + all_packages : pkg_info list; (** All packages *) 49 49 + } 50 50 + 51 51 + (** {1 Generation} *) 52 52 + 53 53 + val collect_data : 54 54 + fs:Eio.Fs.dir_ty Eio.Path.t -> 55 55 + config:Verse_config.t -> 56 56 + ?forks:Forks.t -> 57 57 + registry:Verse_registry.t -> 58 58 + unit -> 59 59 + site_data 60 60 + (** [collect_data ~fs ~config ?forks ~registry ()] scans the workspace and verse members 61 61 + to collect package information for the site. If [forks] is provided, 62 62 + includes fork status information for each repository. *) 63 63 + 64 64 + val generate : 65 65 + fs:Eio.Fs.dir_ty Eio.Path.t -> 66 66 + config:Verse_config.t -> 67 67 + ?forks:Forks.t -> 68 68 + registry:Verse_registry.t -> 69 69 + unit -> 70 70 + string 71 71 + (** [generate ~fs ~config ?forks ~registry ()] generates the HTML content for the site. *) 72 72 + 73 73 + val write : 74 74 + fs:Eio.Fs.dir_ty Eio.Path.t -> 75 75 + config:Verse_config.t -> 76 76 + ?forks:Forks.t -> 77 77 + registry:Verse_registry.t -> 78 78 + output_path:Fpath.t -> 79 79 + unit -> 80 80 + (unit, string) result 81 81 + (** [write ~fs ~config ?forks ~registry ~output_path ()] generates and writes the site 82 82 + to the specified output path. *)

+136

lib/sources_registry.ml

reviewed

··· 1 1 + (** Sources registry for tracking forked/vendored package URLs. *) 2 2 + 3 3 + type origin = Fork | Join 4 4 + 5 5 + type entry = { 6 6 + url : string; 7 7 + upstream : string option; 8 8 + branch : string option; 9 9 + reason : string option; 10 10 + origin : origin option; 11 11 + } 12 12 + 13 13 + type t = { 14 14 + default_url_base : string option; 15 15 + entries : (string * entry) list; 16 16 + } 17 17 + 18 18 + let empty = { default_url_base = None; entries = [] } 19 19 + 20 20 + let default_url_base t = t.default_url_base 21 21 + 22 22 + let with_default_url_base t base = 23 23 + { t with default_url_base = Some base } 24 24 + 25 25 + let find t ~subtree = List.assoc_opt subtree t.entries 26 26 + 27 27 + let derive_url t ~subtree = 28 28 + match find t ~subtree with 29 29 + | Some entry -> Some entry.url 30 30 + | None -> 31 31 + (* Use default_url_base to construct URL from subtree name *) 32 32 + Option.map (fun base -> 33 33 + let base = 34 34 + if String.ends_with ~suffix:"/" base then 35 35 + String.sub base 0 (String.length base - 1) 36 36 + else base 37 37 + in 38 38 + base ^ "/" ^ subtree 39 39 + ) t.default_url_base 40 40 + 41 41 + let add t ~subtree entry = 42 42 + { t with entries = (subtree, entry) :: List.remove_assoc subtree t.entries } 43 43 + 44 44 + let remove t ~subtree = 45 45 + { t with entries = List.remove_assoc subtree t.entries } 46 46 + 47 47 + let to_list t = t.entries 48 48 + 49 49 + let of_list entries = { default_url_base = None; entries } 50 50 + 51 51 + (* TOML structure: 52 52 + default_url_base = "git+https://tangled.org/anil.recoil.org" 53 53 + 54 54 + [braid] 55 55 + url = "git+https://github.com/avsm/braid" 56 56 + upstream = "git+https://github.com/mtelvers/braid" 57 57 + reason = "Maintenance fork" 58 58 + 59 59 + [eio] 60 60 + url = "git+https://github.com/myorg/eio" 61 61 + branch = "backport-5.1" 62 62 + *) 63 63 + 64 64 + let origin_codec : origin Tomlt.t = 65 65 + Tomlt.map 66 66 + ~dec:(function 67 67 + | "fork" -> Fork 68 68 + | "join" -> Join 69 69 + | s -> failwith (Printf.sprintf "Invalid origin: %s (expected 'fork' or 'join')" s)) 70 70 + ~enc:(function Fork -> "fork" | Join -> "join") 71 71 + Tomlt.string 72 72 + 73 73 + let entry_codec : entry Tomlt.t = 74 74 + Tomlt.( 75 75 + Table.( 76 76 + obj (fun url upstream branch reason origin -> { url; upstream; branch; reason; origin }) 77 77 + |> mem "url" string ~enc:(fun e -> e.url) 78 78 + |> opt_mem "upstream" string ~enc:(fun e -> e.upstream) 79 79 + |> opt_mem "branch" string ~enc:(fun e -> e.branch) 80 80 + |> opt_mem "reason" string ~enc:(fun e -> e.reason) 81 81 + |> opt_mem "origin" origin_codec ~enc:(fun e -> e.origin) 82 82 + |> finish)) 83 83 + 84 84 + let codec : t Tomlt.t = 85 85 + Tomlt.( 86 86 + Table.( 87 87 + obj (fun default_url_base entries -> 88 88 + { default_url_base; entries }) 89 89 + |> opt_mem "default_url_base" string ~enc:(fun t -> t.default_url_base) 90 90 + |> keep_unknown ~enc:(fun t -> t.entries) (Mems.assoc entry_codec) 91 91 + |> finish)) 92 92 + 93 93 + let load ~fs path = 94 94 + let path_str = Fpath.to_string path in 95 95 + let eio_path = Eio.Path.(fs / path_str) in 96 96 + (* Check if file exists *) 97 97 + match Eio.Path.kind ~follow:true eio_path with 98 98 + | `Regular_file -> ( 99 99 + try Ok (Tomlt_eio.decode_path_exn codec ~fs path_str) with 100 100 + | Failure msg -> Error (Printf.sprintf "Invalid sources.toml: %s" msg) 101 101 + | exn -> Error (Printf.sprintf "Error loading sources.toml: %s" (Printexc.to_string exn))) 102 102 + | _ -> Ok empty (* File doesn't exist, return empty registry *) 103 103 + | exception _ -> Ok empty 104 104 + 105 105 + let save ~fs path t = 106 106 + let path_str = Fpath.to_string path in 107 107 + try 108 108 + Tomlt_eio.encode_path codec t ~fs path_str; 109 109 + Ok () 110 110 + with exn -> Error (Printexc.to_string exn) 111 111 + 112 112 + let pp_origin ppf = function 113 113 + | Fork -> Fmt.string ppf "fork" 114 114 + | Join -> Fmt.string ppf "join" 115 115 + 116 116 + let pp_entry ppf e = 117 117 + Fmt.pf ppf "@[<hov 2>url: %s" e.url; 118 118 + Option.iter (fun u -> Fmt.pf ppf "@ upstream: %s" u) e.upstream; 119 119 + Option.iter (fun b -> Fmt.pf ppf "@ branch: %s" b) e.branch; 120 120 + Option.iter (fun r -> Fmt.pf ppf "@ reason: %s" r) e.reason; 121 121 + Option.iter (fun o -> Fmt.pf ppf "@ origin: %a" pp_origin o) e.origin; 122 122 + Fmt.pf ppf "@]" 123 123 + 124 124 + let pp ppf t = 125 125 + (match t.default_url_base with 126 126 + | Some base -> Fmt.pf ppf "default_url_base: %s@," base 127 127 + | None -> ()); 128 128 + if t.entries = [] then Fmt.pf ppf "(no source overrides)" 129 129 + else begin 130 130 + Fmt.pf ppf "@[<v>"; 131 131 + List.iter 132 132 + (fun (subtree, entry) -> 133 133 + Fmt.pf ppf "@[<v 2>[%s]@,%a@]@," subtree pp_entry entry) 134 134 + t.entries; 135 135 + Fmt.pf ppf "@]" 136 136 + end

+74

lib/sources_registry.mli

reviewed

··· 1 1 + (** Sources registry for tracking forked/vendored package URLs. 2 2 + 3 3 + The sources.toml file in the monorepo root tracks packages where 4 4 + the dev-repo URL differs from what's declared in dune-project. 5 5 + This is typically used for: 6 6 + - Forked packages (our fork URL vs upstream) 7 7 + - Vendored packages (local copy, custom URL) 8 8 + - Packages without source in dune-project 9 9 + 10 10 + The registry also supports a [default_url_base] field that is used 11 11 + to derive URLs for subtrees without explicit entries: 12 12 + {v 13 13 + default_url_base = "git+https://tangled.org/anil.recoil.org" 14 14 + v} 15 15 + For a subtree named "ocaml-foo", this would produce: 16 16 + [git+https://tangled.org/anil.recoil.org/ocaml-foo] *) 17 17 + 18 18 + (** How a source entry was created. *) 19 19 + type origin = 20 20 + | Fork (** Created via [monopam fork] - subtree split from monorepo *) 21 21 + | Join (** Created via [monopam join] - external repo brought into monorepo *) 22 22 + 23 23 + (** A source entry for a subtree. *) 24 24 + type entry = { 25 25 + url : string; (** Our dev-repo URL (e.g., "git+https://github.com/avsm/braid") *) 26 26 + upstream : string option; (** Original upstream URL if this is a fork *) 27 27 + branch : string option; (** Override branch (default: main) *) 28 28 + reason : string option; (** Why we have a custom source *) 29 29 + origin : origin option; (** How this entry was created *) 30 30 + } 31 31 + 32 32 + (** The sources registry - maps subtree names to source entries. *) 33 33 + type t 34 34 + 35 35 + val empty : t 36 36 + (** Empty registry. *) 37 37 + 38 38 + val default_url_base : t -> string option 39 39 + (** [default_url_base t] returns the default URL base for deriving URLs. *) 40 40 + 41 41 + val with_default_url_base : t -> string -> t 42 42 + (** [with_default_url_base t base] sets the default URL base. *) 43 43 + 44 44 + val find : t -> subtree:string -> entry option 45 45 + (** [find t ~subtree] looks up the source entry for a subtree. *) 46 46 + 47 47 + val derive_url : t -> subtree:string -> string option 48 48 + (** [derive_url t ~subtree] derives a URL for a subtree. 49 49 + First checks for an explicit entry, then uses default_url_base if set. *) 50 50 + 51 51 + val add : t -> subtree:string -> entry -> t 52 52 + (** [add t ~subtree entry] adds or replaces an entry. *) 53 53 + 54 54 + val remove : t -> subtree:string -> t 55 55 + (** [remove t ~subtree] removes an entry. *) 56 56 + 57 57 + val to_list : t -> (string * entry) list 58 58 + (** [to_list t] returns all entries as an association list. *) 59 59 + 60 60 + val of_list : (string * entry) list -> t 61 61 + (** [of_list entries] creates a registry from an association list. *) 62 62 + 63 63 + val load : fs:_ Eio.Path.t -> Fpath.t -> (t, string) result 64 64 + (** [load ~fs path] loads a sources.toml file. Returns empty registry 65 65 + if file doesn't exist. *) 66 66 + 67 67 + val save : fs:_ Eio.Path.t -> Fpath.t -> t -> (unit, string) result 68 68 + (** [save ~fs path t] writes the registry to a TOML file. *) 69 69 + 70 70 + val pp_entry : entry Fmt.t 71 71 + (** Pretty-print a single entry. *) 72 72 + 73 73 + val pp : t Fmt.t 74 74 + (** Pretty-print the registry. *)

+151 -60

lib/status.ml

reviewed

··· 8 8 9 9 (** Sync state between monorepo subtree and local checkout *) 10 10 type subtree_sync = 11 11 - | In_sync (** Subtree matches checkout HEAD *) 12 12 - | Subtree_behind of int (** Subtree needs pull from checkout (checkout has new commits) *) 13 13 - | Subtree_ahead of int (** Subtree has commits not in checkout (need push to checkout) *) 14 14 - | Trees_differ (** Trees differ but can't determine direction/count *) 15 15 - | Unknown (** Can't determine (subtree not added or checkout missing) *) 11 11 + | In_sync (** Subtree matches checkout HEAD *) 12 12 + | Subtree_behind of int 13 13 + (** Subtree needs pull from checkout (checkout has new commits) *) 14 14 + | Subtree_ahead of int 15 15 + (** Subtree has commits not in checkout (need push to checkout) *) 16 16 + | Trees_differ (** Trees differ but can't determine direction/count *) 17 17 + | Unknown (** Can't determine (subtree not added or checkout missing) *) 16 18 17 19 type t = { 18 20 package : Package.t; ··· 58 60 match (checkout, subtree) with 59 61 | (Missing | Not_a_repo | Dirty), _ -> Unknown 60 62 | _, Not_added -> Unknown 61 61 - | Clean _, Present -> 63 63 + | Clean _, Present -> ( 62 64 (* Get tree hash of subtree directory in monorepo *) 63 63 - let subtree_tree = Git.rev_parse ~proc ~fs:fs_t ~rev:("HEAD:" ^ prefix) monorepo in 65 65 + let subtree_tree = 66 66 + Git.rev_parse ~proc ~fs:fs_t ~rev:("HEAD:" ^ prefix) monorepo 67 67 + in 64 68 (* Get tree hash of checkout root *) 65 65 - let checkout_tree = Git.rev_parse ~proc ~fs:fs_t ~rev:"HEAD^{tree}" checkout_dir in 69 69 + let checkout_tree = 70 70 + Git.rev_parse ~proc ~fs:fs_t ~rev:"HEAD^{tree}" checkout_dir 71 71 + in 66 72 match (subtree_tree, checkout_tree) with 67 73 | Ok st, Ok ct when st = ct -> In_sync 68 68 - | Ok _, Ok _ -> 74 74 + | Ok _, Ok _ -> ( 69 75 (* Trees differ - check commit ancestry to determine direction *) 70 76 let subtree_commit = 71 71 - Git.subtree_last_upstream_commit ~proc ~fs:fs_t ~repo:monorepo ~prefix () 77 77 + Git.subtree_last_upstream_commit ~proc ~fs:fs_t ~repo:monorepo 78 78 + ~prefix () 72 79 in 73 80 let checkout_head = Git.head_commit ~proc ~fs:fs_t checkout_dir in 74 74 - (match (subtree_commit, checkout_head) with 81 81 + match (subtree_commit, checkout_head) with 75 82 | Some subtree_sha, Ok checkout_sha -> 76 76 - if Git.is_ancestor ~proc ~fs:fs_t ~repo:checkout_dir 77 77 - ~commit1:subtree_sha ~commit2:checkout_sha () then 83 83 + if 84 84 + Git.is_ancestor ~proc ~fs:fs_t ~repo:checkout_dir 85 85 + ~commit1:subtree_sha ~commit2:checkout_sha () 86 86 + then 78 87 (* Checkout has commits not in subtree - need subtree pull *) 79 79 - let count = Git.count_commits_between ~proc ~fs:fs_t ~repo:checkout_dir 80 80 - ~base:subtree_sha ~head:checkout_sha () in 81 81 - if count > 0 then Subtree_behind count 82 82 - else Trees_differ (* Same commit but trees differ - monorepo has changes *) 83 83 - else if Git.is_ancestor ~proc ~fs:fs_t ~repo:checkout_dir 84 84 - ~commit1:checkout_sha ~commit2:subtree_sha () then 88 88 + let count = 89 89 + Git.count_commits_between ~proc ~fs:fs_t ~repo:checkout_dir 90 90 + ~base:subtree_sha ~head:checkout_sha () 91 91 + in 92 92 + if count > 0 then Subtree_behind count else Trees_differ 93 93 + (* Same commit but trees differ - monorepo has changes *) 94 94 + else if 95 95 + Git.is_ancestor ~proc ~fs:fs_t ~repo:checkout_dir 96 96 + ~commit1:checkout_sha ~commit2:subtree_sha () 97 97 + then 85 98 (* Subtree has content not in checkout - need push *) 86 86 - let count = Git.count_commits_between ~proc ~fs:fs_t ~repo:checkout_dir 87 87 - ~base:checkout_sha ~head:subtree_sha () in 88 88 - if count > 0 then Subtree_ahead count 89 89 - else Trees_differ 90 90 - else 91 91 - Trees_differ (* Diverged *) 92 92 - | _ -> Trees_differ) (* Trees differ but can't determine ancestry *) 93 93 - | _ -> Unknown 99 99 + let count = 100 100 + Git.count_commits_between ~proc ~fs:fs_t ~repo:checkout_dir 101 101 + ~base:checkout_sha ~head:subtree_sha () 102 102 + in 103 103 + if count > 0 then Subtree_ahead count else Trees_differ 104 104 + else Trees_differ (* Diverged *) 105 105 + | _ -> Trees_differ 106 106 + (* Trees differ but can't determine ancestry *)) 107 107 + | _ -> Unknown) 94 108 in 95 109 { package = pkg; checkout; subtree; subtree_sync } 96 110 ··· 113 127 114 128 (** Needs remote action: checkout ahead/behind of upstream *) 115 129 let needs_remote_action t = 116 116 - match t.checkout with 117 117 - | Clean ab -> ab.ahead > 0 || ab.behind > 0 118 118 - | _ -> false 130 130 + match t.checkout with Clean ab -> ab.ahead > 0 || ab.behind > 0 | _ -> false 119 131 120 132 let is_fully_synced t = 121 133 match (t.checkout, t.subtree, t.subtree_sync) with ··· 128 140 match t.checkout with 129 141 | Missing | Not_a_repo | Dirty -> true 130 142 | Clean ab -> 131 131 - ab.ahead > 0 || ab.behind > 0 || 132 132 - t.subtree = Not_added || 133 133 - needs_local_sync t) 143 143 + ab.ahead > 0 || ab.behind > 0 || t.subtree = Not_added 144 144 + || needs_local_sync t) 134 145 statuses 135 146 136 147 let pp_checkout_status ppf = function ··· 149 160 Fmt.pf ppf "@[<h>%-20s checkout: %a subtree: %a@]" (Package.name t.package) 150 161 pp_checkout_status t.checkout pp_subtree_status t.subtree 151 162 163 163 + (** Extract handle from a tangled.org URL like "git+https://tangled.org/handle/repo" *) 164 164 + let extract_handle_from_url url = 165 165 + let url = if String.starts_with ~prefix:"git+" url then 166 166 + String.sub url 4 (String.length url - 4) 167 167 + else url in 168 168 + let uri = Uri.of_string url in 169 169 + match Uri.host uri with 170 170 + | Some "tangled.org" -> 171 171 + let path = Uri.path uri in 172 172 + (* Path is like "/handle/repo" - extract first component *) 173 173 + let path = if String.length path > 0 && path.[0] = '/' then 174 174 + String.sub path 1 (String.length path - 1) 175 175 + else path in 176 176 + (match String.index_opt path '/' with 177 177 + | Some i -> Some (String.sub path 0 i) 178 178 + | None -> Some path) 179 179 + | _ -> None 180 180 + 181 181 + (** Format origin indicator from sources registry entry *) 182 182 + let pp_origin_indicator ppf entry = 183 183 + match entry with 184 184 + | None -> () 185 185 + | Some Sources_registry.{ origin = Some Sources_registry.Fork; _ } -> 186 186 + Fmt.pf ppf " %a" Fmt.(styled `Magenta string) "^" 187 187 + | Some Sources_registry.{ origin = Some Sources_registry.Join; upstream = Some url; _ } -> 188 188 + (match extract_handle_from_url url with 189 189 + | Some handle -> 190 190 + (* Abbreviate handle - take first part before dot, max 8 chars *) 191 191 + let abbrev = match String.index_opt handle '.' with 192 192 + | Some i -> String.sub handle 0 i 193 193 + | None -> handle 194 194 + in 195 195 + let abbrev = if String.length abbrev > 8 then String.sub abbrev 0 8 else abbrev in 196 196 + Fmt.pf ppf " %a" Fmt.(styled `Cyan (fun ppf s -> pf ppf "v:%s" s)) abbrev 197 197 + | None -> Fmt.pf ppf " %a" Fmt.(styled `Cyan string) "v:") 198 198 + | Some Sources_registry.{ origin = Some Sources_registry.Join; _ } -> 199 199 + Fmt.pf ppf " %a" Fmt.(styled `Cyan string) "v:" 200 200 + | Some _ -> () 201 201 + 152 202 (** Compact status for actionable items with colors *) 153 153 - let pp_compact ppf t = 203 203 + let pp_compact ?sources ppf t = 154 204 let name = Package.name t.package in 205 205 + let subtree = Package.subtree_prefix t.package in 206 206 + let entry = match sources with 207 207 + | Some s -> Sources_registry.find s ~subtree 208 208 + | None -> None 209 209 + in 155 210 (* Helper to print remote sync info *) 156 211 let pp_remote ab = 157 212 if ab.Git.ahead > 0 && ab.behind > 0 then 158 158 - Fmt.pf ppf " %a" Fmt.(styled `Yellow (fun ppf (a, b) -> pf ppf "remote:+%d/-%d" a b)) (ab.ahead, ab.behind) 213 213 + Fmt.pf ppf " %a" 214 214 + Fmt.(styled `Yellow (fun ppf (a, b) -> pf ppf "remote:+%d/-%d" a b)) 215 215 + (ab.ahead, ab.behind) 159 216 else if ab.ahead > 0 then 160 160 - Fmt.pf ppf " %a" Fmt.(styled `Cyan (fun ppf n -> pf ppf "remote:+%d" n)) ab.ahead 217 217 + Fmt.pf ppf " %a" 218 218 + Fmt.(styled `Cyan (fun ppf n -> pf ppf "remote:+%d" n)) 219 219 + ab.ahead 161 220 else if ab.behind > 0 then 162 162 - Fmt.pf ppf " %a" Fmt.(styled `Red (fun ppf n -> pf ppf "remote:-%d" n)) ab.behind 221 221 + Fmt.pf ppf " %a" 222 222 + Fmt.(styled `Red (fun ppf n -> pf ppf "remote:-%d" n)) 223 223 + ab.behind 163 224 in 164 225 match (t.checkout, t.subtree, t.subtree_sync) with 165 226 (* Local sync issues with count *) 166 227 | Clean ab, Present, Subtree_behind n -> 167 167 - Fmt.pf ppf "%-22s %a" name Fmt.(styled `Blue (fun ppf n -> pf ppf "local:-%d" n)) n; 168 168 - pp_remote ab 228 228 + Fmt.pf ppf "%-22s %a" name 229 229 + Fmt.(styled `Blue (fun ppf n -> pf ppf "local:-%d" n)) 230 230 + n; 231 231 + pp_remote ab; 232 232 + pp_origin_indicator ppf entry 169 233 | Clean ab, Present, Subtree_ahead n -> 170 170 - Fmt.pf ppf "%-22s %a" name Fmt.(styled `Blue (fun ppf n -> pf ppf "local:+%d" n)) n; 171 171 - pp_remote ab 234 234 + Fmt.pf ppf "%-22s %a" name 235 235 + Fmt.(styled `Blue (fun ppf n -> pf ppf "local:+%d" n)) 236 236 + n; 237 237 + pp_remote ab; 238 238 + pp_origin_indicator ppf entry 172 239 (* Trees differ but can't determine count *) 173 240 | Clean ab, Present, Trees_differ -> 174 241 Fmt.pf ppf "%-22s %a" name Fmt.(styled `Blue string) "local:sync"; 175 175 - pp_remote ab 242 242 + pp_remote ab; 243 243 + pp_origin_indicator ppf entry 176 244 (* Remote sync issues only *) 177 245 | Clean ab, Present, (In_sync | Unknown) when ab.ahead > 0 && ab.behind > 0 -> 178 178 - Fmt.pf ppf "%-22s %a" name Fmt.(styled `Yellow (fun ppf (a,b) -> pf ppf "remote:+%d/-%d" a b)) (ab.ahead, ab.behind) 246 246 + Fmt.pf ppf "%-22s %a" name 247 247 + Fmt.(styled `Yellow (fun ppf (a, b) -> pf ppf "remote:+%d/-%d" a b)) 248 248 + (ab.ahead, ab.behind); 249 249 + pp_origin_indicator ppf entry 179 250 | Clean ab, Present, (In_sync | Unknown) when ab.ahead > 0 -> 180 180 - Fmt.pf ppf "%-22s %a" name Fmt.(styled `Cyan (fun ppf n -> pf ppf "remote:+%d" n)) ab.ahead 251 251 + Fmt.pf ppf "%-22s %a" name 252 252 + Fmt.(styled `Cyan (fun ppf n -> pf ppf "remote:+%d" n)) 253 253 + ab.ahead; 254 254 + pp_origin_indicator ppf entry 181 255 | Clean ab, Present, (In_sync | Unknown) when ab.behind > 0 -> 182 182 - Fmt.pf ppf "%-22s %a" name Fmt.(styled `Red (fun ppf n -> pf ppf "remote:-%d" n)) ab.behind 256 256 + Fmt.pf ppf "%-22s %a" name 257 257 + Fmt.(styled `Red (fun ppf n -> pf ppf "remote:-%d" n)) 258 258 + ab.behind; 259 259 + pp_origin_indicator ppf entry 183 260 (* Other issues *) 184 261 | Clean _, Not_added, _ -> 185 185 - Fmt.pf ppf "%-22s %a" name Fmt.(styled `Magenta string) "(no subtree)" 262 262 + Fmt.pf ppf "%-22s %a" name Fmt.(styled `Magenta string) "(no subtree)"; 263 263 + pp_origin_indicator ppf entry 186 264 | Missing, _, _ -> 187 187 - Fmt.pf ppf "%-22s %a" name Fmt.(styled `Red string) "(no checkout)" 265 265 + Fmt.pf ppf "%-22s %a" name Fmt.(styled `Red string) "(no checkout)"; 266 266 + pp_origin_indicator ppf entry 188 267 | Not_a_repo, _, _ -> 189 189 - Fmt.pf ppf "%-22s %a" name Fmt.(styled `Red string) "(not a repo)" 268 268 + Fmt.pf ppf "%-22s %a" name Fmt.(styled `Red string) "(not a repo)"; 269 269 + pp_origin_indicator ppf entry 190 270 | Dirty, _, _ -> 191 191 - Fmt.pf ppf "%-22s %a" name Fmt.(styled `Yellow string) "(dirty)" 271 271 + Fmt.pf ppf "%-22s %a" name Fmt.(styled `Yellow string) "(dirty)"; 272 272 + pp_origin_indicator ppf entry 192 273 | Clean _, Present, (In_sync | Unknown) -> 193 193 - Fmt.pf ppf "%-22s %a" name Fmt.(styled `Green string) "ok" 274 274 + Fmt.pf ppf "%-22s %a" name Fmt.(styled `Green string) "ok"; 275 275 + pp_origin_indicator ppf entry 194 276 195 195 - let pp_summary ppf statuses = 277 277 + let pp_summary ?sources ppf statuses = 196 278 let total = List.length statuses in 197 279 let actionable = filter_actionable statuses in 198 280 let synced = List.filter is_fully_synced statuses |> List.length in 199 281 let dirty = List.filter has_local_changes statuses |> List.length in 200 200 - let local_sync_needed = List.filter needs_local_sync statuses |> List.length in 282 282 + let local_sync_needed = 283 283 + List.filter needs_local_sync statuses |> List.length 284 284 + in 201 285 let remote_needed = List.filter needs_remote_action statuses |> List.length in 202 286 let action_count = List.length actionable in 203 287 (* Header line with colors *) 204 288 if dirty > 0 then 205 289 Fmt.pf ppf "%a %d total, %a synced, %a dirty\n" 206 206 - Fmt.(styled `Bold string) "Packages:" total 207 207 - Fmt.(styled `Green int) synced 208 208 - Fmt.(styled `Yellow int) dirty 290 290 + Fmt.(styled `Bold string) 291 291 + "Packages:" total 292 292 + Fmt.(styled `Green int) 293 293 + synced 294 294 + Fmt.(styled `Yellow int) 295 295 + dirty 209 296 else if action_count > 0 then begin 210 297 Fmt.pf ppf "%a %d total, %a synced" 211 211 - Fmt.(styled `Bold string) "Packages:" total 212 212 - Fmt.(styled `Green int) synced; 298 298 + Fmt.(styled `Bold string) 299 299 + "Packages:" total 300 300 + Fmt.(styled `Green int) 301 301 + synced; 213 302 if local_sync_needed > 0 then 214 303 Fmt.pf ppf ", %a local sync" Fmt.(styled `Blue int) local_sync_needed; 215 304 if remote_needed > 0 then ··· 218 307 end 219 308 else 220 309 Fmt.pf ppf "%a %d total, %a\n" 221 221 - Fmt.(styled `Bold string) "Packages:" total 222 222 - Fmt.(styled `Green string) "all synced"; 310 310 + Fmt.(styled `Bold string) 311 311 + "Packages:" total 312 312 + Fmt.(styled `Green string) 313 313 + "all synced"; 223 314 (* Only show actionable items *) 224 315 if actionable <> [] then 225 225 - List.iter (fun t -> Fmt.pf ppf " %a\n" pp_compact t) actionable 316 316 + List.iter (fun t -> Fmt.pf ppf " %a\n" (pp_compact ?sources) t) actionable

+9 -5

lib/status.mli

reviewed

··· 18 18 | Not_added (** Subtree has not been added to monorepo *) 19 19 | Present (** Subtree exists in monorepo *) 20 20 21 21 - (** Sync state between monorepo subtree and local checkout. 22 22 - This distinguishes issues fixable with [monopam sync] from those 23 23 - requiring network access. *) 21 21 + (** Sync state between monorepo subtree and local checkout. This distinguishes 22 22 + issues fixable with [monopam sync] from those requiring network access. *) 24 23 type subtree_sync = 25 24 | In_sync (** Subtree matches checkout HEAD *) 26 25 | Subtree_behind of int ··· 113 112 val pp : t Fmt.t 114 113 (** [pp] formats a single package status. *) 115 114 116 116 - val pp_summary : t list Fmt.t 117 117 - (** [pp_summary] formats a summary of all package statuses. *) 115 115 + val pp_compact : ?sources:Sources_registry.t -> t Fmt.t 116 116 + (** [pp_compact ?sources] formats a single package status in compact form with colors. 117 117 + If [sources] is provided, displays origin indicators (^ for fork, v:handle for join). *) 118 118 + 119 119 + val pp_summary : ?sources:Sources_registry.t -> t list Fmt.t 120 120 + (** [pp_summary ?sources] formats a summary of all package statuses. 121 121 + If [sources] is provided, displays origin indicators for each package. *)

+125 -70

lib/verse.ml

reviewed

··· 25 25 26 26 let error_hint = function 27 27 | Config_error _ -> 28 28 - Some "Run 'monopam verse init --handle <your-handle>' to create a workspace." 28 28 + Some 29 29 + "Run 'monopam init --handle <your-handle>' to create a workspace." 29 30 | Git_error (Git.Dirty_worktree _) -> 30 31 Some "Commit or stash your changes first: git status" 31 31 - | Git_error (Git.Command_failed (cmd, _)) when String.starts_with ~prefix:"git clone" cmd -> 32 32 + | Git_error (Git.Command_failed (cmd, _)) 33 33 + when String.starts_with ~prefix:"git clone" cmd -> 32 34 Some "Check the URL is correct and you have network access." 33 33 - | Git_error (Git.Command_failed (cmd, _)) when String.starts_with ~prefix:"git pull" cmd -> 35 35 + | Git_error (Git.Command_failed (cmd, _)) 36 36 + when String.starts_with ~prefix:"git pull" cmd -> 34 37 Some "Check your network connection. Try: git fetch origin" 35 38 | Git_error _ -> None 36 39 | Registry_error _ -> 37 40 Some "The registry may be temporarily unavailable. Try again later." 38 41 | Member_not_found h -> 39 39 - Some (Fmt.str "Check available members: monopam verse members (looking for '%s')" h) 42 42 + Some 43 43 + (Fmt.str 44 44 + "Check available members: monopam verse members (looking for '%s')" h) 40 45 | Workspace_exists _ -> 41 46 Some "Use a different directory, or remove the existing workspace." 42 47 | Not_a_workspace _ -> 43 43 - Some "Run 'monopam verse init --handle <your-handle>' to create a workspace here." 48 48 + Some "Run 'monopam init --handle <your-handle>' to create a workspace here." 44 49 | Package_not_found (pkg, handle) -> 45 50 Some (Fmt.str "Run 'monopam verse pull %s' to sync their opam repo, then check package name: %s" handle pkg) 46 51 | Package_already_exists pkgs -> ··· 84 89 85 90 let pp_status ppf s = 86 91 Fmt.pf ppf "@[<v>Workspace: %a@,Registry: %s@,Members:@, @[<v>%a@]@]" 87 87 - Fpath.pp (Verse_config.root s.config) 92 92 + Fpath.pp 93 93 + (Verse_config.root s.config) 88 94 s.registry.name 89 95 Fmt.(list ~sep:cut pp_member_status) 90 96 s.tracked_members ··· 118 124 let eio_path = Eio.Path.(fs / Fpath.to_string verse_path) in 119 125 try 120 126 Eio.Path.read_dir eio_path 121 121 - |> List.filter (fun name -> 122 122 - is_directory ~fs Fpath.(verse_path / name)) 127 127 + |> List.filter (fun name -> is_directory ~fs Fpath.(verse_path / name)) 123 128 with Eio.Io _ -> [] 124 129 125 130 let init ~proc ~fs ~root ~handle () = ··· 141 146 (* Ensure the directory exists first so realpath works *) 142 147 (try Eio.Path.mkdirs ~perm:0o755 eio_path with Eio.Io _ -> ()); 143 148 match Unix.realpath root_str with 144 144 - | abs_str -> (match Fpath.of_string abs_str with Ok p -> p | Error _ -> root) 149 149 + | abs_str -> ( 150 150 + match Fpath.of_string abs_str with Ok p -> p | Error _ -> root) 145 151 | exception _ -> root 146 152 in 147 153 Logs.info (fun m -> m "Workspace root: %a" Fpath.pp root); ··· 153 159 | Error msg -> 154 160 Logs.err (fun m -> m "Registry clone failed: %s" msg); 155 161 Error (Registry_error msg) 156 156 - | Ok registry -> 162 162 + | Ok registry -> ( 157 163 Logs.info (fun m -> m "Registry loaded"); 158 164 (* Look up user in registry - this validates the handle *) 159 165 match Verse_registry.find_member registry ~handle with 160 166 | None -> 161 167 Logs.err (fun m -> m "Handle %s not found in registry" handle); 162 168 Error (Member_not_found handle) 163 163 - | Some member -> 164 164 - Logs.info (fun m -> m "Found member: mono=%s opam=%s" member.monorepo member.opamrepo); 165 165 - (* Create workspace directories *) 166 166 - Logs.info (fun m -> m "Creating workspace directories..."); 167 167 - ensure_dir ~fs root; 168 168 - ensure_dir ~fs (Verse_config.src_path config); 169 169 - ensure_dir ~fs (Verse_config.verse_path config); 170 170 - (* Clone user's monorepo *) 171 171 - let mono_path = Verse_config.mono_path config in 172 172 - Logs.info (fun m -> m "Cloning monorepo to %a" Fpath.pp mono_path); 173 173 - let mono_url = Uri.of_string member.monorepo in 174 174 - (match Git.clone ~proc ~fs ~url:mono_url ~branch:Verse_config.default_branch mono_path with 169 169 + | Some member -> ( 170 170 + Logs.info (fun m -> 171 171 + m "Found member: mono=%s opam=%s" member.monorepo 172 172 + member.opamrepo); 173 173 + (* Create workspace directories *) 174 174 + Logs.info (fun m -> m "Creating workspace directories..."); 175 175 + ensure_dir ~fs root; 176 176 + ensure_dir ~fs (Verse_config.src_path config); 177 177 + ensure_dir ~fs (Verse_config.verse_path config); 178 178 + (* Clone user's monorepo *) 179 179 + let mono_path = Verse_config.mono_path config in 180 180 + Logs.info (fun m -> m "Cloning monorepo to %a" Fpath.pp mono_path); 181 181 + let mono_url = Uri.of_string member.monorepo in 182 182 + match 183 183 + Git.clone ~proc ~fs ~url:mono_url 184 184 + ~branch:Verse_config.default_branch mono_path 185 185 + with 186 186 + | Error e -> 187 187 + Logs.err (fun m -> m "Monorepo clone failed: %a" Git.pp_error e); 188 188 + Error (Git_error e) 189 189 + | Ok () -> ( 190 190 + Logs.info (fun m -> m "Monorepo cloned"); 191 191 + (* Clone user's opam repo *) 192 192 + let opam_path = Verse_config.opam_repo_path config in 193 193 + Logs.info (fun m -> 194 194 + m "Cloning opam repo to %a" Fpath.pp opam_path); 195 195 + let opam_url = Uri.of_string member.opamrepo in 196 196 + match 197 197 + Git.clone ~proc ~fs ~url:opam_url 198 198 + ~branch:Verse_config.default_branch opam_path 199 199 + with 175 200 | Error e -> 176 176 - Logs.err (fun m -> m "Monorepo clone failed: %a" Git.pp_error e); 201 201 + Logs.err (fun m -> 202 202 + m "Opam repo clone failed: %a" Git.pp_error e); 177 203 Error (Git_error e) 178 178 - | Ok () -> 179 179 - Logs.info (fun m -> m "Monorepo cloned"); 180 180 - (* Clone user's opam repo *) 181 181 - let opam_path = Verse_config.opam_repo_path config in 182 182 - Logs.info (fun m -> m "Cloning opam repo to %a" Fpath.pp opam_path); 183 183 - let opam_url = Uri.of_string member.opamrepo in 184 184 - (match Git.clone ~proc ~fs ~url:opam_url ~branch:Verse_config.default_branch opam_path with 185 185 - | Error e -> 186 186 - Logs.err (fun m -> m "Opam repo clone failed: %a" Git.pp_error e); 187 187 - Error (Git_error e) 204 204 + | Ok () -> ( 205 205 + Logs.info (fun m -> m "Opam repo cloned"); 206 206 + (* Save config to XDG *) 207 207 + Logs.info (fun m -> 208 208 + m "Saving config to %a" Fpath.pp config_file); 209 209 + match Verse_config.save ~fs config with 210 210 + | Error msg -> 211 211 + Logs.err (fun m -> m "Failed to save config: %s" msg); 212 212 + Error (Config_error msg) 188 213 | Ok () -> 189 189 - Logs.info (fun m -> m "Opam repo cloned"); 190 190 - (* Save config to XDG *) 191 191 - Logs.info (fun m -> m "Saving config to %a" Fpath.pp config_file); 192 192 - (match Verse_config.save ~fs config with 193 193 - | Error msg -> 194 194 - Logs.err (fun m -> m "Failed to save config: %s" msg); 195 195 - Error (Config_error msg) 196 196 - | Ok () -> 197 197 - Logs.info (fun m -> m "Workspace initialized successfully"); 198 198 - Ok ()))) 214 214 + Logs.info (fun m -> 215 215 + m "Workspace initialized successfully"); 216 216 + Ok ())))) 199 217 200 218 let status ~proc ~fs ~config () = 201 219 (* Load registry *) ··· 212 230 match Verse_registry.find_member registry ~handle with 213 231 | None -> 214 232 (* Member not in registry but locally tracked - show anyway *) 215 215 - let local_path = Fpath.(Verse_config.verse_path config / handle) in 233 233 + let local_path = 234 234 + Fpath.(Verse_config.verse_path config / handle) 235 235 + in 216 236 let cloned = is_directory ~fs local_path in 217 237 Some 218 238 { ··· 257 277 | Error msg -> Error (Registry_error msg) 258 278 | Ok registry -> Ok registry.members 259 279 260 260 - 261 280 (** Clone or fetch+reset a single git repo. Returns Ok true if cloned, Ok false if reset. 262 281 Uses fetch+reset instead of pull since verse repos should not have local changes. *) 263 282 let clone_or_reset_repo ~proc ~fs ~url ~branch path = ··· 278 297 match Verse_registry.clone_or_pull ~proc ~fs ~config () with 279 298 | Error msg -> Error (Registry_error msg) 280 299 | Ok registry -> 281 281 - let members = match handle with 282 282 - | Some h -> 283 283 - (match Verse_registry.find_member registry ~handle:h with 284 284 - | Some m -> [m] 300 300 + let members = 301 301 + match handle with 302 302 + | Some h -> ( 303 303 + match Verse_registry.find_member registry ~handle:h with 304 304 + | Some m -> [ m ] 285 305 | None -> []) 286 306 | None -> registry.members 287 307 in ··· 306 326 clone_or_reset_repo ~proc ~fs ~url:member.monorepo 307 327 ~branch:mono_branch mono_path 308 328 in 309 309 - let mono_err = match mono_result with 310 310 - | Ok true -> Logs.info (fun m -> m " Cloned %s monorepo" h); None 311 311 - | Ok false -> Logs.info (fun m -> m " Reset %s monorepo" h); None 329 329 + let mono_err = 330 330 + match mono_result with 331 331 + | Ok true -> 332 332 + Logs.info (fun m -> m " Cloned %s monorepo" h); 333 333 + None 334 334 + | Ok false -> 335 335 + Logs.info (fun m -> m " Reset %s monorepo" h); 336 336 + None 312 337 | Error e -> 313 313 - Logs.warn (fun m -> m " Failed %s monorepo: %a" h Git.pp_error e); 338 338 + Logs.warn (fun m -> 339 339 + m " Failed %s monorepo: %a" h Git.pp_error e); 314 340 Some (Fmt.str "%s monorepo: %a" h Git.pp_error e) 315 341 in 316 342 (* Clone or fetch+reset opam repo *) ··· 322 348 clone_or_reset_repo ~proc ~fs ~url:member.opamrepo 323 349 ~branch:opam_branch opam_path 324 350 in 325 325 - let opam_err = match opam_result with 326 326 - | Ok true -> Logs.info (fun m -> m " Cloned %s opam repo" h); None 327 327 - | Ok false -> Logs.info (fun m -> m " Reset %s opam repo" h); None 351 351 + let opam_err = 352 352 + match opam_result with 353 353 + | Ok true -> 354 354 + Logs.info (fun m -> m " Cloned %s opam repo" h); 355 355 + None 356 356 + | Ok false -> 357 357 + Logs.info (fun m -> m " Reset %s opam repo" h); 358 358 + None 328 359 | Error e -> 329 329 - Logs.warn (fun m -> m " Failed %s opam repo: %a" h Git.pp_error e); 360 360 + Logs.warn (fun m -> 361 361 + m " Failed %s opam repo: %a" h Git.pp_error e); 330 362 Some (Fmt.str "%s opam: %a" h Git.pp_error e) 331 363 in 332 364 match (mono_err, opam_err) with ··· 343 375 (* pull already updates registry and syncs all members *) 344 376 pull ~proc ~fs ~config () 345 377 346 346 - (** Scan a monorepo for subtree directories. 347 347 - Returns a list of directory names that look like subtrees (have commits). *) 378 378 + (** Scan a monorepo for subtree directories. Returns a list of directory names 379 379 + that look like subtrees (have commits). *) 348 380 let scan_subtrees ~proc ~fs monorepo_path = 349 381 if not (Git.is_repo ~proc ~fs monorepo_path) then [] 350 382 else ··· 352 384 try 353 385 Eio.Path.read_dir eio_path 354 386 |> List.filter (fun name -> 355 355 - (* Skip hidden dirs and common non-subtree dirs *) 356 356 - not (String.starts_with ~prefix:"." name) 357 357 - && name <> "_build" 358 358 - && name <> "node_modules" 359 359 - && is_directory ~fs Fpath.(monorepo_path / name)) 387 387 + (* Skip hidden dirs and common non-subtree dirs *) 388 388 + (not (String.starts_with ~prefix:"." name)) 389 389 + && name <> "_build" && name <> "node_modules" 390 390 + && is_directory ~fs Fpath.(monorepo_path / name)) 360 391 with Eio.Io _ -> [] 361 392 362 362 - (** Get subtrees from all tracked verse members. 363 363 - Returns a map from subtree name to list of (handle, monorepo_path) pairs. *) 393 393 + (** Get subtrees from all tracked verse members. Returns a map from subtree name 394 394 + to list of (handle, monorepo_path) pairs. *) 364 395 let get_verse_subtrees ~proc ~fs ~config () = 365 396 let verse_path = Verse_config.verse_path config in 366 397 let tracked_handles = get_tracked_handles ~fs config in ··· 376 407 let existing = 377 408 try Hashtbl.find subtree_map subtree with Not_found -> [] 378 409 in 379 379 - Hashtbl.replace subtree_map subtree ((handle, member_mono) :: existing)) 410 410 + Hashtbl.replace subtree_map subtree 411 411 + ((handle, member_mono) :: existing)) 380 412 subtrees 381 413 end) 382 414 tracked_handles; ··· 387 419 packages_forked : string list; (** Package names that were forked *) 388 420 source_handle : string; (** Handle of the verse member we forked from *) 389 421 fork_url : string; (** URL of the fork *) 422 422 + upstream_url : string; (** Original dev-repo URL (upstream) *) 423 423 + subtree_name : string; (** Name for the subtree directory (derived from fork URL) *) 390 424 } 391 425 426 426 + (** Extract subtree name from a URL (last path component without .git suffix) *) 427 427 + let subtree_name_from_url url = 428 428 + let uri = Uri.of_string url in 429 429 + let path = Uri.path uri in 430 430 + (* Remove leading slash and .git suffix *) 431 431 + let path = if String.length path > 0 && path.[0] = '/' then 432 432 + String.sub path 1 (String.length path - 1) 433 433 + else path in 434 434 + let path = if String.ends_with ~suffix:".git" path then 435 435 + String.sub path 0 (String.length path - 4) 436 436 + else path in 437 437 + (* Get last component *) 438 438 + match String.rindex_opt path '/' with 439 439 + | Some i -> String.sub path (i + 1) (String.length path - i - 1) 440 440 + | None -> path 441 441 + 392 442 let pp_fork_result ppf r = 393 393 - Fmt.pf ppf "@[<v>Forked %d package(s) from %s:@, @[<v>%a@]@,Fork URL: %s@]" 443 443 + Fmt.pf ppf "@[<v>Forked %d package(s) from %s:@, @[<v>%a@]@,Fork URL: %s@,Upstream: %s@,Subtree: %s@]" 394 444 (List.length r.packages_forked) 395 445 r.source_handle 396 446 Fmt.(list ~sep:cut string) r.packages_forked 397 447 r.fork_url 448 448 + r.upstream_url 449 449 + r.subtree_name 398 450 399 451 (** Fork a package from a verse member's opam repo into your workspace. 400 452 ··· 434 486 List.filter (fun p -> Package.same_repo p pkg) pkgs 435 487 in 436 488 let pkg_names = List.map Package.name related_pkgs in 489 489 + (* Get upstream URL and subtree name *) 490 490 + let upstream_url = Uri.to_string (Package.dev_repo pkg) in 491 491 + let subtree_name = subtree_name_from_url fork_url in 437 492 (* Check for conflicts in user's opam-repo *) 438 493 let user_opam_repo = Verse_config.opam_repo_path config in 439 494 let conflicts = ··· 445 500 Error (Package_already_exists conflicts) 446 501 else if dry_run then 447 502 (* Dry run - just report what would be done *) 448 448 - Ok { packages_forked = pkg_names; source_handle = handle; fork_url } 503 503 + Ok { packages_forked = pkg_names; source_handle = handle; fork_url; upstream_url; subtree_name } 449 504 else begin 450 505 (* Fork each package *) 451 506 let results = ··· 472 527 | Some (Error e) -> Error e 473 528 | _ -> 474 529 let forked_names = List.filter_map (function Ok n -> Some n | Error _ -> None) results in 475 475 - Ok { packages_forked = forked_names; source_handle = handle; fork_url } 530 530 + Ok { packages_forked = forked_names; source_handle = handle; fork_url; upstream_url; subtree_name } 476 531 end

+12 -7

lib/verse.mli

reviewed

··· 1 1 (** Monoverse operations. 2 2 3 3 - Federated monorepo collaboration. Members are identified by handles 4 4 - and validated against the registry. *) 3 3 + Federated monorepo collaboration. Members are identified by handles and 4 4 + validated against the registry. *) 5 5 6 6 (** {1 Error Types} *) 7 7 ··· 20 20 (** [pp_error] formats errors. *) 21 21 22 22 val pp_error_with_hint : error Fmt.t 23 23 - (** [pp_error_with_hint] formats errors with a helpful hint for resolving them. *) 23 23 + (** [pp_error_with_hint] formats errors with a helpful hint for resolving them. 24 24 + *) 24 25 25 26 val error_hint : error -> string option 26 27 (** [error_hint e] returns a hint string for the given error, if available. *) ··· 33 34 local_path : Fpath.t; (** Local path under verse/ *) 34 35 cloned : bool; (** Whether the monorepo is cloned locally *) 35 36 clean : bool option; (** Whether the clone is clean (None if not cloned) *) 36 36 - ahead_behind : Git.ahead_behind option; (** Ahead/behind status (None if not cloned) *) 37 37 + ahead_behind : Git.ahead_behind option; 38 38 + (** Ahead/behind status (None if not cloned) *) 37 39 } 38 40 (** Status of a member's monorepo in the workspace. *) 39 41 ··· 104 106 (unit, error) result 105 107 (** [pull ~proc ~fs ~config ?handle ()] syncs all registry members. 106 108 107 107 - For each member in the registry, clones or pulls both their monorepo 108 108 - (to [verse/<handle>/]) and their opam repo (to [verse/<handle>-opam/]). 109 109 + For each member in the registry, clones or pulls both their monorepo (to 110 110 + [verse/<handle>/]) and their opam repo (to [verse/<handle>-opam/]). 109 111 110 112 If [handle] is specified, only syncs that specific member. 111 113 ··· 140 142 unit -> 141 143 (string, (string * Fpath.t) list) Hashtbl.t 142 144 (** [get_verse_subtrees ~proc ~fs ~config ()] scans all tracked verse members 143 143 - and returns a map from subtree name to list of (handle, monorepo_path) pairs. 145 145 + and returns a map from subtree name to list of (handle, monorepo_path) 146 146 + pairs. 144 147 145 148 This allows finding which verse users have a particular repo. *) 146 149 ··· 151 154 packages_forked : string list; (** Package names that were forked *) 152 155 source_handle : string; (** Handle of the verse member we forked from *) 153 156 fork_url : string; (** URL of the fork *) 157 157 + upstream_url : string; (** Original dev-repo URL (upstream) *) 158 158 + subtree_name : string; (** Name for the subtree directory (derived from fork URL) *) 154 159 } 155 160 156 161 val pp_fork_result : fork_result Fmt.t

+6 -116

lib/verse_config.ml

reviewed

··· 1 1 - let app_name = "monopam" 2 2 - 3 3 - (* Simplified config: just root and handle. Paths are hardcoded. *) 4 4 - type t = { 5 5 - root : Fpath.t; 6 6 - handle : string; 7 7 - } 8 8 - 9 9 - let root t = t.root 10 10 - let handle t = t.handle 11 11 - 12 12 - (* Hardcoded paths derived from root *) 13 13 - let default_branch = "main" 14 14 - let mono_path t = Fpath.(t.root / "mono") 15 15 - let src_path t = Fpath.(t.root / "src") 16 16 - let opam_repo_path t = Fpath.(t.root / "opam-repo") 17 17 - let verse_path t = Fpath.(t.root / "verse") 18 18 - 19 19 - (* Compute XDG directories following XDG Base Directory Specification *) 20 20 - let xdg_config_home () = 21 21 - match Sys.getenv_opt "XDG_CONFIG_HOME" with 22 22 - | Some dir when dir <> "" -> Fpath.v dir 23 23 - | _ -> 24 24 - match Sys.getenv_opt "HOME" with 25 25 - | Some home -> Fpath.(v home / ".config") 26 26 - | None -> Fpath.v "/tmp" 27 27 - 28 28 - let xdg_data_home () = 29 29 - match Sys.getenv_opt "XDG_DATA_HOME" with 30 30 - | Some dir when dir <> "" -> Fpath.v dir 31 31 - | _ -> 32 32 - match Sys.getenv_opt "HOME" with 33 33 - | Some home -> Fpath.(v home / ".local" / "share") 34 34 - | None -> Fpath.v "/tmp" 35 35 - 36 36 - let config_dir () = Fpath.(xdg_config_home () / app_name) 37 37 - let data_dir () = Fpath.(xdg_data_home () / app_name) 38 38 - let config_file () = Fpath.(config_dir () / "opamverse.toml") 39 39 - let registry_path () = Fpath.(data_dir () / "opamverse-registry") 40 40 - 41 41 - let create ~root ~handle () = { root; handle } 42 42 - 43 43 - let expand_tilde s = 44 44 - if String.length s > 0 && s.[0] = '~' then 45 45 - match Sys.getenv_opt "HOME" with 46 46 - | Some home -> 47 47 - if String.length s = 1 then home 48 48 - else if s.[1] = '/' then home ^ String.sub s 1 (String.length s - 1) 49 49 - else s 50 50 - | None -> s 51 51 - else s 52 52 - 53 53 - let fpath_codec : Fpath.t Tomlt.t = 54 54 - Tomlt.map 55 55 - ~dec:(fun s -> 56 56 - let s = expand_tilde s in 57 57 - match Fpath.of_string s with Ok p -> p | Error (`Msg m) -> failwith m) 58 58 - ~enc:Fpath.to_string Tomlt.string 59 59 - 60 60 - (* Simplified TOML structure: 61 61 - [workspace] 62 62 - root = "~/tangled" 1 1 + (** Verse_config is now an alias for Config. 63 2 64 64 - [identity] 65 65 - handle = "anil.recoil.org" 66 66 - *) 3 3 + This module is kept for backwards compatibility. 4 4 + All functionality has been unified into Config. *) 67 5 68 68 - type workspace_section = { w_root : Fpath.t } 69 69 - type identity_section = { i_handle : string } 6 6 + include Config 70 7 71 71 - let workspace_codec : workspace_section Tomlt.t = 72 72 - Tomlt.( 73 73 - Table.( 74 74 - obj (fun w_root -> { w_root }) 75 75 - |> mem "root" fpath_codec ~enc:(fun w -> w.w_root) 76 76 - |> finish)) 77 77 - 78 78 - let identity_codec : identity_section Tomlt.t = 79 79 - Tomlt.( 80 80 - Table.( 81 81 - obj (fun i_handle -> { i_handle }) 82 82 - |> mem "handle" string ~enc:(fun i -> i.i_handle) 83 83 - |> finish)) 84 84 - 85 85 - let codec : t Tomlt.t = 86 86 - Tomlt.( 87 87 - Table.( 88 88 - obj (fun workspace identity -> 89 89 - { root = workspace.w_root; handle = identity.i_handle }) 90 90 - |> mem "workspace" workspace_codec ~enc:(fun t -> { w_root = t.root }) 91 91 - |> mem "identity" identity_codec ~enc:(fun t -> { i_handle = t.handle }) 92 92 - |> finish)) 93 93 - 94 94 - let load ~fs () = 95 95 - let path = config_file () in 96 96 - let path_str = Fpath.to_string path in 97 97 - try Ok (Tomlt_eio.decode_path_exn codec ~fs path_str) 98 98 - with 99 99 - | Eio.Io _ as e -> Error (Printexc.to_string e) 100 100 - | Failure msg -> Error (Fmt.str "Invalid config: %s" msg) 101 101 - 102 102 - let save ~fs t = 103 103 - let dir = config_dir () in 104 104 - let path = config_file () in 105 105 - try 106 106 - (* Ensure XDG config directory exists *) 107 107 - let dir_path = Eio.Path.(fs / Fpath.to_string dir) in 108 108 - (try Eio.Path.mkdirs ~perm:0o755 dir_path with Eio.Io _ -> ()); 109 109 - Tomlt_eio.encode_path codec t ~fs (Fpath.to_string path); 110 110 - Ok () 111 111 - with Eio.Io _ as e -> Error (Printexc.to_string e) 112 112 - 113 113 - let pp ppf t = 114 114 - Fmt.pf ppf 115 115 - "@[<v>workspace:@,\ 116 116 - \ root: %a@,\ 117 117 - identity:@,\ 118 118 - \ handle: %s@]" 119 119 - Fpath.pp t.root t.handle 8 8 + (** Legacy type alias for package overrides *) 9 9 + type package_override = Config.Package_config.t

+8 -79

lib/verse_config.mli

reviewed

··· 1 1 - (** Opamverse workspace configuration. 2 2 - 3 3 - Configuration is stored in the XDG config directory at 4 4 - [~/.config/monopam/opamverse.toml]. 5 5 - 6 6 - The config stores just the workspace root and user's handle. 7 7 - All paths are derived from the root: 8 8 - - [mono/] - user's monorepo 9 9 - - [src/] - git checkouts for subtrees 10 10 - - [opam-repo/] - opam overlay repository 11 11 - - [verse/] - other members' monorepos *) 12 12 - 13 13 - (** {1 Types} *) 14 14 - 15 15 - type t 16 16 - (** Opamverse workspace configuration. *) 17 17 - 18 18 - (** {1 Accessors} *) 19 19 - 20 20 - val root : t -> Fpath.t 21 21 - (** [root t] returns the workspace root directory. *) 22 22 - 23 23 - val handle : t -> string 24 24 - (** [handle t] returns the user's tangled handle. *) 25 25 - 26 26 - (** {1 Derived Paths} *) 1 1 + (** Verse_config is now an alias for Config. 27 2 28 28 - val default_branch : string 29 29 - (** Default git branch, always ["main"]. *) 30 30 - 31 31 - val mono_path : t -> Fpath.t 32 32 - (** [mono_path t] returns the path to the user's monorepo ([root/mono/]). *) 3 3 + This module is kept for backwards compatibility. 4 4 + All functionality has been unified into Config. 33 5 34 34 - val src_path : t -> Fpath.t 35 35 - (** [src_path t] returns the path to git checkouts ([root/src/]). *) 6 6 + @deprecated Use {!Config} directly. *) 36 7 37 37 - val opam_repo_path : t -> Fpath.t 38 38 - (** [opam_repo_path t] returns the path to the opam overlay ([root/opam-repo/]). *) 8 8 + include module type of Config 39 9 40 40 - val verse_path : t -> Fpath.t 41 41 - (** [verse_path t] returns the path to tracked members' monorepos ([root/verse/]). *) 42 42 - 43 43 - (** {1 XDG Paths} *) 44 44 - 45 45 - val config_dir : unit -> Fpath.t 46 46 - (** [config_dir ()] returns the XDG config directory for monopam 47 47 - (~/.config/monopam). *) 48 48 - 49 49 - val data_dir : unit -> Fpath.t 50 50 - (** [data_dir ()] returns the XDG data directory for monopam 51 51 - (~/.local/share/monopam). *) 52 52 - 53 53 - val config_file : unit -> Fpath.t 54 54 - (** [config_file ()] returns the path to the opamverse config file 55 55 - (~/.config/monopam/opamverse.toml). *) 56 56 - 57 57 - val registry_path : unit -> Fpath.t 58 58 - (** [registry_path ()] returns the path to the cloned registry git repo 59 59 - (~/.local/share/monopam/opamverse-registry). *) 60 60 - 61 61 - (** {1 Loading and Saving} *) 62 62 - 63 63 - val load : fs:Eio.Fs.dir_ty Eio.Path.t -> unit -> (t, string) result 64 64 - (** [load ~fs ()] loads the workspace configuration from the XDG config file. 65 65 - 66 66 - @param fs Eio filesystem *) 67 67 - 68 68 - val save : fs:Eio.Fs.dir_ty Eio.Path.t -> t -> (unit, string) result 69 69 - (** [save ~fs config] saves the configuration to the XDG config file. 70 70 - 71 71 - @param fs Eio filesystem 72 72 - @param config Configuration to save *) 73 73 - 74 74 - val create : root:Fpath.t -> handle:string -> unit -> t 75 75 - (** [create ~root ~handle ()] creates a new configuration. 76 76 - 77 77 - @param root Workspace root directory (absolute path) 78 78 - @param handle User's tangled handle *) 79 79 - 80 80 - (** {1 Pretty Printing} *) 81 81 - 82 82 - val pp : t Fmt.t 83 83 - (** [pp] formats a workspace configuration. *) 10 10 + (** Legacy type alias for package overrides. 11 11 + @deprecated Use {!Config.Package_config.t} instead. *) 12 12 + type package_override = Config.Package_config.t

+34 -25

lib/verse_registry.ml

reviewed

··· 1 1 type member = { 2 2 handle : string; 3 3 + name : string option; 3 4 monorepo : string; 4 5 monorepo_branch : string option; 5 6 opamrepo : string; 6 7 opamrepo_branch : string option; 7 8 } 8 8 - type t = { name : string; members : member list } 9 9 + type t = { name : string; description : string option; members : member list } 9 10 10 11 let default_url = "https://tangled.org/eeg.cl.cam.ac.uk/opamverse" 11 12 ··· 27 28 let pp_member ppf m = 28 29 let mono_str = encode_url_with_branch m.monorepo m.monorepo_branch in 29 30 let opam_str = encode_url_with_branch m.opamrepo m.opamrepo_branch in 30 30 - Fmt.pf ppf "@[<hov 2>%s ->@ mono:%s@ opam:%s@]" m.handle mono_str opam_str 31 31 + let name_str = match m.name with Some n -> n | None -> m.handle in 32 32 + Fmt.pf ppf "@[<hov 2>%s (%s) ->@ mono:%s@ opam:%s@]" name_str m.handle mono_str opam_str 31 33 32 34 let pp ppf t = 33 33 - Fmt.pf ppf "@[<v>registry: %s@,members:@, @[<v>%a@]@]" 34 34 - t.name Fmt.(list ~sep:cut pp_member) t.members 35 35 + Fmt.pf ppf "@[<v>registry: %s%a@,members:@, @[<v>%a@]@]" t.name 36 36 + Fmt.(option (fun ppf s -> pf ppf "@,description: %s" s)) t.description 37 37 + Fmt.(list ~sep:cut pp_member) 38 38 + t.members 35 39 36 40 (* TOML structure: 37 41 [registry] ··· 46 50 let member_codec : member Tomlt.t = 47 51 Tomlt.( 48 52 Table.( 49 49 - obj (fun handle monorepo_raw opamrepo_raw -> 53 53 + obj (fun handle name monorepo_raw opamrepo_raw -> 50 54 let monorepo, monorepo_branch = parse_url_with_branch monorepo_raw in 51 55 let opamrepo, opamrepo_branch = parse_url_with_branch opamrepo_raw in 52 52 - { handle; monorepo; monorepo_branch; opamrepo; opamrepo_branch }) 53 53 - |> mem "handle" string ~enc:(fun m -> m.handle) 54 54 - |> mem "monorepo" string ~enc:(fun m -> encode_url_with_branch m.monorepo m.monorepo_branch) 55 55 - |> mem "opamrepo" string ~enc:(fun m -> encode_url_with_branch m.opamrepo m.opamrepo_branch) 56 56 + { handle; name; monorepo; monorepo_branch; opamrepo; opamrepo_branch }) 57 57 + |> mem "handle" string ~enc:(fun (m : member) -> m.handle) 58 58 + |> opt_mem "name" string ~enc:(fun (m : member) -> m.name) 59 59 + |> mem "monorepo" string ~enc:(fun (m : member) -> encode_url_with_branch m.monorepo m.monorepo_branch) 60 60 + |> mem "opamrepo" string ~enc:(fun (m : member) -> encode_url_with_branch m.opamrepo m.opamrepo_branch) 56 61 |> finish)) 57 62 58 58 - type registry_info = { r_name : string } 63 63 + type registry_info = { r_name : string; r_description : string option } 59 64 60 65 let registry_info_codec : registry_info Tomlt.t = 61 66 Tomlt.( 62 67 Table.( 63 63 - obj (fun r_name -> { r_name }) 68 68 + obj (fun r_name r_description -> { r_name; r_description }) 64 69 |> mem "name" string ~enc:(fun r -> r.r_name) 70 70 + |> opt_mem "description" string ~enc:(fun r -> r.r_description) 65 71 |> finish)) 66 72 67 73 let codec : t Tomlt.t = 68 74 Tomlt.( 69 75 Table.( 70 76 obj (fun registry members -> 71 71 - { name = registry.r_name; members = Option.value ~default:[] members }) 72 72 - |> mem "registry" registry_info_codec ~enc:(fun t -> { r_name = t.name }) 77 77 + { name = registry.r_name; description = registry.r_description; members = Option.value ~default:[] members }) 78 78 + |> mem "registry" registry_info_codec ~enc:(fun t -> { r_name = t.name; r_description = t.description }) 73 79 |> opt_mem "members" (list member_codec) ~enc:(fun t -> 74 74 - match t.members with [] -> None | ms -> Some ms) 80 80 + match t.members with [] -> None | ms -> Some ms) 75 81 |> finish)) 76 82 77 77 - let empty_registry = { name = "opamverse"; members = [] } 83 83 + let empty_registry = { name = "opamverse"; description = None; members = [] } 78 84 79 85 let load ~fs path = 80 86 let path_str = Fpath.to_string path in 81 87 Logs.info (fun m -> m "Loading registry from path: %s" path_str); 82 88 try 83 89 let registry = Tomlt_eio.decode_path_exn codec ~fs path_str in 84 84 - Logs.info (fun m -> m "Registry loaded: %d members" (List.length registry.members)); 90 90 + Logs.info (fun m -> 91 91 + m "Registry loaded: %d members" (List.length registry.members)); 85 92 Ok registry 86 93 with 87 94 | Eio.Io _ as e -> ··· 91 98 Logs.err (fun m -> m "Registry parse error: %s" msg); 92 99 Error (Fmt.str "Invalid registry: %s" msg) 93 100 | exn -> 94 94 - Logs.err (fun m -> m "Unexpected registry error: %s" (Printexc.to_string exn)); 101 101 + Logs.err (fun m -> 102 102 + m "Unexpected registry error: %s" (Printexc.to_string exn)); 95 103 Error (Fmt.str "Registry error: %s" (Printexc.to_string exn)) 96 104 97 105 let save ~fs path registry = ··· 117 125 Logs.info (fun m -> m "Registry exists, pulling updates..."); 118 126 (* Pull updates, but don't fail if pull fails *) 119 127 (match Git.pull ~proc ~fs registry_path with 120 120 - | Ok () -> Logs.info (fun m -> m "Registry pull succeeded") 121 121 - | Error e -> Logs.warn (fun m -> m "Registry pull failed: %a (using cached)" Git.pp_error e)); 128 128 + | Ok () -> Logs.info (fun m -> m "Registry pull succeeded") 129 129 + | Error e -> 130 130 + Logs.warn (fun m -> 131 131 + m "Registry pull failed: %a (using cached)" Git.pp_error e)); 122 132 Logs.info (fun m -> m "Loading registry from %a" Fpath.pp registry_toml); 123 133 load ~fs registry_toml 124 134 end ··· 143 153 (try Eio.Path.mkdirs ~perm:0o755 registry_eio with Eio.Io _ -> ()); 144 154 (* Initialize as git repo *) 145 155 (match Git.init ~proc ~fs registry_path with 146 146 - | Ok () -> () 147 147 - | Error _ -> ()); 156 156 + | Ok () -> () 157 157 + | Error _ -> ()); 148 158 (* Create empty registry file *) 149 159 (match save ~fs registry_toml empty_registry with 150 150 - | Ok () -> () 151 151 - | Error _ -> ()); 160 160 + | Ok () -> () 161 161 + | Error _ -> ()); 152 162 Ok empty_registry 153 163 end 154 164 155 155 - let find_member t ~handle = 156 156 - List.find_opt (fun m -> m.handle = handle) t.members 165 165 + let find_member t ~handle = List.find_opt (fun m -> m.handle = handle) t.members 157 166 158 167 let find_members t ~handles = 159 168 List.filter (fun m -> List.mem m.handle handles) t.members

+4 -2

lib/verse_registry.mli

reviewed

··· 7 7 8 8 type member = { 9 9 handle : string; (** Tangled handle (e.g., "alice.bsky.social") *) 10 10 + name : string option; (** Display name (e.g., "Alice Smith") *) 10 11 monorepo : string; (** Git URL of the member's monorepo *) 11 12 monorepo_branch : string option; (** Optional branch for monorepo (from URL#branch) *) 12 13 opamrepo : string; (** Git URL of the member's opam overlay repository *) ··· 19 20 20 21 type t = { 21 22 name : string; (** Registry name *) 23 23 + description : string option; (** Registry description *) 22 24 members : member list; (** List of registered members *) 23 25 } 24 26 (** The parsed registry contents. *) ··· 34 36 config:Verse_config.t -> 35 37 unit -> 36 38 (t, string) result 37 37 - (** [clone_or_pull ~proc ~fs ~config ()] clones the registry if not present, 38 38 - or pulls updates if it exists. Returns the parsed registry contents. 39 39 + (** [clone_or_pull ~proc ~fs ~config ()] clones the registry if not present, or 40 40 + pulls updates if it exists. Returns the parsed registry contents. 39 41 40 42 The registry is cloned to [config.registry_path]. 41 43

+2

monopam.opam

reviewed

··· 25 25 "jsont" {>= "0.2.0"} 26 26 "requests" 27 27 "ptime" {>= "1.0.0"} 28 28 + "sexplib0" {>= "0.17.0"} 29 29 + "parsexp" {>= "0.17.0"} 28 30 "odoc" {with-doc} 29 31 ] 30 32 build: [