+67 -75

lib/changes.ml

reviewed

··· 23 23 module Daily = Changes_daily 24 24 module Query = Changes_query 25 25 26 26 + (** {1 Error Helpers} *) 27 27 + 28 28 + let err_parse name e = Error (Fmt.str "Failed to parse %s: %s" name e) 29 29 + let err_encode name e = Error (Fmt.str "Failed to encode %s: %s" name e) 30 30 + let err_claude_parse e = Error (Fmt.str "Failed to parse Claude response: %s" e) 31 31 + let err_decode e = Error (Fmt.str "Failed to decode response: %s" e) 32 32 + 26 33 type commit_range = { from_hash : string; to_hash : string; count : int } 27 34 28 35 type weekly_entry = { ··· 160 167 let content = Eio.Path.load file_path in 161 168 match Jsont_bytesrw.decode_string changes_file_jsont content with 162 169 | Ok cf -> Ok cf 163 163 - | Error e -> 164 164 - Error (Format.sprintf "Failed to parse %s.json: %s" repo_name e)) 170 170 + | Error e -> err_parse (repo_name ^ ".json") e) 165 171 | _ -> Ok { repository = repo_name; entries = [] } 166 172 | exception Eio.Io _ -> Ok { repository = repo_name; entries = [] } 167 173 ··· 178 184 | Ok content -> 179 185 Eio.Path.save ~create:(`Or_truncate 0o644) file_path content; 180 186 Ok () 181 181 - | Error e -> 182 182 - Error (Format.sprintf "Failed to encode %s.json: %s" cf.repository e) 187 187 + | Error e -> err_encode (cf.repository ^ ".json") e 183 188 184 189 (* Filename for daily changes: <repo>-<YYYY-MM-DD>.json *) 185 190 let daily_filename repo_name date = repo_name ^ "-" ^ date ^ ".json" ··· 206 211 let content = Eio.Path.load file_path in 207 212 match Jsont_bytesrw.decode_string daily_changes_file_jsont content with 208 213 | Ok cf -> Ok cf 209 209 - | Error e -> Error (Format.sprintf "Failed to parse %s: %s" filename e)) 214 214 + | Error e -> err_parse filename e) 210 215 | _ -> Ok { repository = repo_name; entries = [] } 211 216 | exception Eio.Io _ -> Ok { repository = repo_name; entries = [] } 212 217 ··· 223 228 | Ok content -> 224 229 Eio.Path.save ~create:(`Or_truncate 0o644) file_path content; 225 230 Ok () 226 226 - | Error e -> Error (Format.sprintf "Failed to encode %s: %s" filename e) 231 231 + | Error e -> err_encode filename e 227 232 228 233 (* Markdown generation *) 229 234 230 235 let to_markdown (cf : changes_file) = 231 236 let buf = Buffer.create 1024 in 232 232 - Buffer.add_string buf (Printf.sprintf "# %s Changelog\n\n" cf.repository); 237 237 + Buffer.add_string buf (Fmt.str "# %s Changelog\n\n" cf.repository); 233 238 List.iter 234 239 (fun (entry : weekly_entry) -> 235 240 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); 241 241 + (Fmt.str "## Week of %s to %s\n\n" entry.week_start entry.week_end); 242 242 + Buffer.add_string buf (Fmt.str "%s\n\n" entry.summary); 239 243 List.iter 240 240 - (fun change -> Buffer.add_string buf (Printf.sprintf "- %s\n" change)) 244 244 + (fun change -> Buffer.add_string buf (Fmt.str "- %s\n" change)) 241 245 entry.changes; 242 246 Buffer.add_string buf "\n") 243 247 cf.entries; ··· 286 290 Buffer.add_string buf "# Changelog\n\n"; 287 291 List.iter 288 292 (fun (week_key, entries) -> 289 289 - Buffer.add_string buf (Printf.sprintf "## Week of %s\n\n" week_key); 293 293 + Buffer.add_string buf (Fmt.str "## Week of %s\n\n" week_key); 290 294 List.iter 291 295 (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); 296 296 + Buffer.add_string buf (Fmt.str "### %s\n" repo); 297 297 + Buffer.add_string buf (Fmt.str "%s\n" entry.summary); 294 298 List.iter 295 295 - (fun change -> 296 296 - Buffer.add_string buf (Printf.sprintf "- %s\n" change)) 299 299 + (fun change -> Buffer.add_string buf (Fmt.str "- %s\n" change)) 297 300 entry.changes; 298 301 Buffer.add_string buf "\n") 299 302 entries) ··· 347 350 in 348 351 loop y m d n 349 352 350 350 - let format_date (y, m, d) = Printf.sprintf "%04d-%02d-%02d" y m d 353 353 + let format_date (y, m, d) = Fmt.str "%04d-%02d-%02d" y m d 351 354 352 355 let week_of_date (y, m, d) = 353 356 let dow = day_of_week y m d in ··· 395 398 This function now checks if the file has any entries. *) 396 399 cf.entries <> [] 397 400 401 401 + (* Format a single daily entry for markdown *) 402 402 + let format_daily_entry buf repo (entry : daily_entry) = 403 403 + let repo_header = 404 404 + match entry.repo_url with 405 405 + | Some url -> Fmt.str "[%s](%s)" repo url 406 406 + | None -> repo 407 407 + in 408 408 + Buffer.add_string buf (Fmt.str "### %s\n\n" repo_header); 409 409 + Buffer.add_string buf (Fmt.str "%s\n\n" entry.summary); 410 410 + List.iter 411 411 + (fun change -> Buffer.add_string buf (Fmt.str "- %s\n" change)) 412 412 + entry.changes; 413 413 + if entry.contributors <> [] then begin 414 414 + let contributors_str = String.concat ", " entry.contributors in 415 415 + Buffer.add_string buf (Fmt.str "\n*Contributors: %s*\n" contributors_str) 416 416 + end; 417 417 + Buffer.add_string buf "\n" 418 418 + 419 419 + (* Format entries for a single date *) 420 420 + let format_date_entries buf date entries = 421 421 + let entries_with_changes = 422 422 + List.filter (fun (_, (entry : daily_entry)) -> entry.changes <> []) entries 423 423 + in 424 424 + if entries_with_changes <> [] then begin 425 425 + Buffer.add_string buf (Fmt.str "## %s\n\n" date); 426 426 + List.iter 427 427 + (fun (repo, (entry : daily_entry)) -> format_daily_entry buf repo entry) 428 428 + entries_with_changes 429 429 + end 430 430 + 398 431 (* Aggregate daily changes into DAILY-CHANGES.md *) 399 432 let aggregate_daily ~history (cfs : daily_changes_file list) = 400 433 (* Collect all entries from all files, tagged with repository *) ··· 437 470 let buf = Buffer.create 4096 in 438 471 Buffer.add_string buf "# Daily Changelog\n\n"; 439 472 List.iter 440 440 - (fun (date, entries) -> 441 441 - (* Filter out entries with empty changes - these are repos with no changes *) 442 442 - let entries_with_changes = 443 443 - List.filter 444 444 - (fun (_, (entry : daily_entry)) -> entry.changes <> []) 445 445 - entries 446 446 - in 447 447 - if entries_with_changes <> [] then begin 448 448 - Buffer.add_string buf (Printf.sprintf "## %s\n\n" date); 449 449 - List.iter 450 450 - (fun (repo, (entry : daily_entry)) -> 451 451 - (* Format repo name with link if URL available *) 452 452 - let repo_header = 453 453 - match entry.repo_url with 454 454 - | Some url -> Printf.sprintf "[%s](%s)" repo url 455 455 - | None -> repo 456 456 - in 457 457 - Buffer.add_string buf (Printf.sprintf "### %s\n\n" repo_header); 458 458 - Buffer.add_string buf (Printf.sprintf "%s\n\n" entry.summary); 459 459 - List.iter 460 460 - (fun change -> 461 461 - Buffer.add_string buf (Printf.sprintf "- %s\n" change)) 462 462 - entry.changes; 463 463 - (* Add contributors if any *) 464 464 - if entry.contributors <> [] then begin 465 465 - let contributors_str = String.concat ", " entry.contributors in 466 466 - Buffer.add_string buf 467 467 - (Printf.sprintf "\n*Contributors: %s*\n" contributors_str) 468 468 - end; 469 469 - Buffer.add_string buf "\n") 470 470 - entries_with_changes 471 471 - end) 473 473 + (fun (date, entries) -> format_date_entries buf date entries) 472 474 limited; 473 475 Buffer.contents buf 474 476 ··· 477 479 let generate_weekly_prompt ~repository ~week_start ~week_end commits = 478 480 let buf = Buffer.create 4096 in 479 481 Buffer.add_string buf 480 480 - (Printf.sprintf 481 481 - "You are analyzing git commits for the OCaml library \"%s\".\n" 482 482 + (Fmt.str "You are analyzing git commits for the OCaml library \"%s\".\n" 482 483 repository); 483 484 Buffer.add_string buf 484 484 - (Printf.sprintf 485 485 + (Fmt.str 485 486 "Generate a user-facing changelog entry for the week of %s to %s.\n\n" 486 487 week_start week_end); 487 488 Buffer.add_string buf "## Commits this week:\n\n"; 488 489 List.iter 489 490 (fun (commit : Git.Repository.log_entry) -> 490 491 Buffer.add_string buf 491 491 - (Printf.sprintf "### %s by %s (%s)\n" 492 492 + (Fmt.str "### %s by %s (%s)\n" 492 493 (String.sub commit.hash 0 (min 7 (String.length commit.hash))) 493 494 commit.author commit.date); 494 494 - Buffer.add_string buf (Printf.sprintf "%s\n\n" commit.subject); 495 495 + Buffer.add_string buf (Fmt.str "%s\n\n" commit.subject); 495 496 if commit.body <> "" then begin 496 496 - Buffer.add_string buf (Printf.sprintf "%s\n" commit.body) 497 497 + Buffer.add_string buf (Fmt.str "%s\n" commit.body) 497 498 end; 498 499 Buffer.add_string buf "---\n\n") 499 500 commits; ··· 532 533 let generate_daily_prompt ~repository ~date commits = 533 534 let buf = Buffer.create 4096 in 534 535 Buffer.add_string buf 535 535 - (Printf.sprintf 536 536 - "You are analyzing git commits for the OCaml library \"%s\".\n" 536 536 + (Fmt.str "You are analyzing git commits for the OCaml library \"%s\".\n" 537 537 repository); 538 538 Buffer.add_string buf 539 539 - (Printf.sprintf "Generate a user-facing changelog entry for %s.\n\n" date); 539 539 + (Fmt.str "Generate a user-facing changelog entry for %s.\n\n" date); 540 540 Buffer.add_string buf "## Commits today:\n\n"; 541 541 List.iter 542 542 (fun (commit : Git.Repository.log_entry) -> 543 543 Buffer.add_string buf 544 544 - (Printf.sprintf "### %s by %s (%s)\n" 544 544 + (Fmt.str "### %s by %s (%s)\n" 545 545 (String.sub commit.hash 0 (min 7 (String.length commit.hash))) 546 546 commit.author commit.date); 547 547 - Buffer.add_string buf (Printf.sprintf "%s\n\n" commit.subject); 547 547 + Buffer.add_string buf (Fmt.str "%s\n\n" commit.subject); 548 548 if commit.body <> "" then begin 549 549 - Buffer.add_string buf (Printf.sprintf "%s\n" commit.body) 549 549 + Buffer.add_string buf (Fmt.str "%s\n" commit.body) 550 550 end; 551 551 Buffer.add_string buf "---\n\n") 552 552 commits; ··· 606 606 | Ok r -> 607 607 (* Treat empty summary and changes as no changes *) 608 608 if r.summary = "" && r.changes = [] then Ok None else Ok (Some r) 609 609 - | Error e -> Error (Format.sprintf "Failed to parse Claude response: %s" e) 609 609 + | Error e -> err_claude_parse e 610 610 611 611 (* Main analysis function *) 612 612 ··· 674 674 | Some json -> ( 675 675 match Jsont.Json.decode claude_response_jsont json with 676 676 | Ok r -> result := Some (Ok (Some r)) 677 677 - | Error e -> 678 678 - result := 679 679 - Some 680 680 - (Error 681 681 - (Format.sprintf "Failed to decode response: %s" e))) 677 677 + | Error e -> result := Some (err_decode e)) 682 678 | None -> ( 683 679 (* Try to get text and parse it as fallback *) 684 680 match Claude.Response.Complete.result_text c with ··· 691 687 result := 692 688 Some 693 689 (Error 694 694 - (Printf.sprintf "Claude error: %s" 690 690 + (Fmt.str "Claude error: %s" 695 691 (Claude.Response.Error.message e))) 696 692 | _ -> ()) 697 693 responses; ··· 767 763 if r.summary = "" && r.changes = [] then 768 764 result := Some (Ok None) 769 765 else result := Some (Ok (Some r)) 770 770 - | Error e -> 771 771 - result := 772 772 - Some 773 773 - (Error 774 774 - (Format.sprintf "Failed to decode response: %s" e))) 766 766 + | Error e -> result := Some (err_decode e)) 775 767 | None -> ( 776 768 (* Try to get text and parse it as fallback *) 777 769 match Claude.Response.Complete.result_text c with ··· 784 776 result := 785 777 Some 786 778 (Error 787 787 - (Printf.sprintf "Claude error: %s" 779 779 + (Fmt.str "Claude error: %s" 788 780 (Claude.Response.Error.message e))) 789 781 | _ -> ()) 790 782 responses; ··· 795 787 (* Refine daily changelog markdown to be more narrative *) 796 788 let refine_daily_changelog ~sw ~process_mgr ~clock markdown = 797 789 let prompt = 798 798 - Printf.sprintf 790 790 + Fmt.str 799 791 {|You are editing a daily changelog for an OCaml monorepo. 800 792 801 793 Your task is to refine the following changelog to be:

+11 -4

lib/changes_aggregated.ml

reviewed

··· 10 10 repository changes for a single day into a structured format suitable for 11 11 broadcasting. *) 12 12 13 13 + (** {1 Error Helpers} *) 14 14 + 15 15 + let err_parse filename e = Error (Fmt.str "Failed to parse %s: %s" filename e) 16 16 + let err_not_found filename = Error (Fmt.str "File not found: %s" filename) 17 17 + let err_read filename = Error (Fmt.str "Could not read %s" filename) 18 18 + let err_encode filename e = Error (Fmt.str "Failed to encode %s: %s" filename e) 19 19 + 13 20 type change_type = 14 21 | Feature 15 22 | Bugfix ··· 162 169 let content = Eio.Path.load file_path in 163 170 match Jsont_bytesrw.decode_string jsont content with 164 171 | Ok t -> Ok t 165 165 - | Error e -> Error (Format.sprintf "Failed to parse %s: %s" filename e)) 166 166 - | _ -> Error (Format.sprintf "File not found: %s" filename) 167 167 - | exception Eio.Io _ -> Error (Format.sprintf "Could not read %s" filename) 172 172 + | Error e -> err_parse filename e) 173 173 + | _ -> err_not_found filename 174 174 + | exception Eio.Io _ -> err_read filename 168 175 169 176 let load_range ~fs ~changes_dir ~from_date ~to_date = 170 177 (* List all YYYYMMDD.json files and filter by range *) ··· 241 248 | Ok content -> 242 249 Eio.Path.save ~create:(`Or_truncate 0o644) file_path content; 243 250 Ok () 244 244 - | Error e -> Error (Format.sprintf "Failed to encode %s: %s" filename e) 251 251 + | Error e -> err_encode filename e

+6

lib/changes_aggregated.mli

reviewed

··· 22 22 | Unknown (** Unclassified changes *) 23 23 24 24 val change_type_of_string : string -> change_type 25 25 + (** Convert a string to a change type. Unknown strings map to {!Unknown}. *) 26 26 + 25 27 val string_of_change_type : change_type -> string 28 28 + (** Convert a change type to its string representation. *) 26 29 27 30 (** {1 Entry Types} *) 28 31 ··· 60 63 (** {1 JSON Codecs} *) 61 64 62 65 val jsont : t Jsont.t 66 66 + (** JSON codec for the aggregated changes file. *) 67 67 + 63 68 val entry_jsont : entry Jsont.t 69 69 + (** JSON codec for a single entry. *) 64 70 65 71 (** {1 File I/O} *) 66 72

+64 -72

lib/changes_query.ml

reviewed

··· 12 12 (* Get the date part of since for filtering *) 13 13 let since_date = 14 14 let (y, m, d), _ = Ptime.to_date_time since in 15 15 - Printf.sprintf "%04d-%02d-%02d" y m d 15 15 + Fmt.str "%04d-%02d-%02d" y m d 16 16 in 17 17 (* Get current date for range end *) 18 18 let now_date = 19 19 let (y, m, d), _ = Ptime.to_date_time now in 20 20 - Printf.sprintf "%04d-%02d-%02d" y m d 20 20 + Fmt.str "%04d-%02d-%02d" y m d 21 21 in 22 22 match 23 23 Changes_aggregated.load_range ~fs ~changes_dir ~from_date:since_date ··· 41 41 42 42 let format_repo_link repo url_opt = 43 43 match url_opt with 44 44 - | Some url -> Printf.sprintf "[%s](%s)" repo url 44 44 + | Some url -> Fmt.str "[%s](%s)" repo url 45 45 | None -> repo (* No URL available, just use repo name *) 46 46 47 47 + let format_entry_zulip buf (entry : Changes_aggregated.entry) = 48 48 + let repo_link = format_repo_link entry.repository entry.repo_url in 49 49 + Buffer.add_string buf (Fmt.str "**%s**: %s\n" repo_link entry.summary); 50 50 + List.iter 51 51 + (fun change -> Buffer.add_string buf (Fmt.str "- %s\n" change)) 52 52 + entry.changes; 53 53 + if entry.contributors <> [] then 54 54 + Buffer.add_string buf 55 55 + (Fmt.str "*Contributors: %s*\n" (String.concat ", " entry.contributors)); 56 56 + Buffer.add_string buf "\n" 57 57 + 58 58 + let format_type_section buf title entries = 59 59 + if entries <> [] then begin 60 60 + Buffer.add_string buf (Fmt.str "### %s\n\n" title); 61 61 + List.iter (format_entry_zulip buf) entries 62 62 + end 63 63 + 47 64 let format_for_zulip ~entries ~include_date ~date = 48 65 if entries = [] then "No changes to report." 49 66 else begin 50 67 let buf = Buffer.create 1024 in 51 51 - if include_date then begin 52 52 - match date with 53 53 - | Some d -> Buffer.add_string buf (Printf.sprintf "Updates for %s:\n\n" d) 54 54 - | None -> Buffer.add_string buf "Recent updates:\n\n" 55 55 - end; 68 68 + if include_date then 69 69 + Buffer.add_string buf 70 70 + (match date with 71 71 + | Some d -> Fmt.str "Updates for %s:\n\n" d 72 72 + | None -> "Recent updates:\n\n"); 56 73 (* Group by change type *) 57 74 let by_type = 58 75 [ 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", []); 76 76 + (Changes_aggregated.New_library, "New Libraries"); 77 77 + (Changes_aggregated.Feature, "Features"); 78 78 + (Changes_aggregated.Bugfix, "Bug Fixes"); 79 79 + (Changes_aggregated.Documentation, "Documentation"); 80 80 + (Changes_aggregated.Refactor, "Improvements"); 81 81 + (Changes_aggregated.Unknown, "Other Changes"); 65 82 ] 66 83 in 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 84 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") 85 85 + (fun (ct, title) -> 86 86 + let matching = 87 87 + List.filter 88 88 + (fun (e : Changes_aggregated.entry) -> e.change_type = ct) 98 89 entries 99 99 - end) 100 100 - grouped; 90 90 + in 91 91 + format_type_section buf title matching) 92 92 + by_type; 101 93 Buffer.contents buf 102 94 end 103 95 ··· 109 101 List.sort_uniq String.compare 110 102 (List.map (fun (e : Changes_aggregated.entry) -> e.repository) entries) 111 103 in 112 112 - Printf.sprintf "%d change%s across %d repositor%s: %s" count 104 104 + Fmt.str "%d change%s across %d repositor%s: %s" count 113 105 (if count = 1 then "" else "s") 114 106 (List.length repos) 115 107 (if List.length repos = 1 then "y" else "ies") ··· 123 115 let has_new_daily_changes ~fs ~changes_dir ~since = 124 116 daily_changes_since ~fs ~changes_dir ~since <> [] 125 117 118 118 + let format_daily_entry buf (entry : Changes_daily.entry) = 119 119 + Buffer.add_string buf (Fmt.str "**%s**\n" entry.summary); 120 120 + List.iter 121 121 + (fun change -> Buffer.add_string buf (Fmt.str "- %s\n" change)) 122 122 + entry.changes; 123 123 + if entry.contributors <> [] then 124 124 + Buffer.add_string buf 125 125 + (Fmt.str "*Contributors: %s*\n" (String.concat ", " entry.contributors)); 126 126 + Buffer.add_string buf "\n" 127 127 + 128 128 + let format_repo_section buf repo repo_entries = 129 129 + if repo_entries <> [] then begin 130 130 + let first_entry = List.hd repo_entries in 131 131 + let repo_link = format_repo_link repo first_entry.Changes_daily.repo_url in 132 132 + Buffer.add_string buf (Fmt.str "### %s\n\n" repo_link); 133 133 + List.iter (format_daily_entry buf) repo_entries 134 134 + end 135 135 + 126 136 let format_daily_for_zulip ~entries ~include_date ~date = 127 137 if entries = [] then "No changes to report." 128 138 else begin 129 139 let buf = Buffer.create 1024 in 130 130 - if include_date then begin 131 131 - match date with 132 132 - | Some d -> 133 133 - Buffer.add_string buf (Printf.sprintf "## Changes for %s\n\n" d) 134 134 - | None -> Buffer.add_string buf "## Recent Changes\n\n" 135 135 - end; 140 140 + if include_date then 141 141 + Buffer.add_string buf 142 142 + (match date with 143 143 + | Some d -> Fmt.str "## Changes for %s\n\n" d 144 144 + | None -> "## Recent Changes\n\n"); 136 145 (* Group by repository *) 137 146 let repos = 138 147 List.sort_uniq String.compare ··· 145 154 (fun (e : Changes_daily.entry) -> e.repository = repo) 146 155 entries 147 156 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) 157 157 + format_repo_section buf repo repo_entries) 166 158 repos; 167 159 Buffer.contents buf 168 160 end ··· 175 167 List.sort_uniq String.compare 176 168 (List.map (fun (e : Changes_daily.entry) -> e.repository) entries) 177 169 in 178 178 - Printf.sprintf "%d change%s across %d repositor%s: %s" count 170 170 + Fmt.str "%d change%s across %d repositor%s: %s" count 179 171 (if count = 1 then "" else "s") 180 172 (List.length repos) 181 173 (if List.length repos = 1 then "y" else "ies")

+9 -7

lib/config.ml

reviewed

··· 3 3 Configuration is stored in TOML format at ~/.config/monopam/opamverse.toml 4 4 *) 5 5 6 6 + (** {1 Error Helpers} *) 7 7 + 8 8 + let err_invalid msg = Error (Fmt.str "Invalid config: %s" msg) 9 9 + let err_load e = Error (Fmt.str "Error loading config: %s" e) 10 10 + let err_not_found path = Error (Fmt.str "Config file not found: %s" path) 6 11 let app_name = "monopam" 7 12 8 13 (** {1 Package Overrides} *) ··· 260 265 match Eio.Path.kind ~follow:true eio_path with 261 266 | `Regular_file -> ( 262 267 try Ok (Tomlt_eio.decode_path_exn codec ~fs path_str) with 263 263 - | Failure msg -> Error (Printf.sprintf "Invalid config: %s" msg) 264 264 - | exn -> 265 265 - Error 266 266 - (Printf.sprintf "Error loading config: %s" (Printexc.to_string exn)) 267 267 - ) 268 268 - | _ -> Error (Printf.sprintf "Config file not found: %s" path_str) 269 269 - | exception _ -> Error (Printf.sprintf "Config file not found: %s" path_str) 268 268 + | Failure msg -> err_invalid msg 269 269 + | exn -> err_load (Printexc.to_string exn)) 270 270 + | _ -> err_not_found path_str 271 271 + | exception _ -> err_not_found path_str 270 272 271 273 let save ~fs t = 272 274 let dir = config_dir () in

+13 -14

lib/dune_project.ml

reviewed

··· 55 55 | _ -> None 56 56 57 57 (** Find name in (package (name foo) ...) stanza *) 58 58 - let rec find_package_name = function 58 58 + let rec package_name = function 59 59 | [] -> None 60 60 | Sexp.List [ Sexp.Atom "name"; Sexp.Atom name ] :: _ -> Some name 61 61 - | _ :: rest -> find_package_name rest 61 61 + | _ :: rest -> package_name rest 62 62 63 63 (** Extract all package names from parsed sexps *) 64 64 let extract_packages sexps = 65 65 List.filter_map 66 66 (function 67 67 - | Sexp.List (Sexp.Atom "package" :: rest) -> find_package_name rest 68 68 - | _ -> None) 67 67 + | Sexp.List (Sexp.Atom "package" :: rest) -> package_name rest | _ -> None) 69 68 sexps 70 69 71 70 (** Find a simple string field like (name foo) or (homepage "url") *) 72 72 - let find_string_field name sexps = 71 71 + let string_field name sexps = 73 72 List.find_map 74 73 (function 75 74 | Sexp.List [ Sexp.Atom n; value ] when n = name -> atom_string value ··· 77 76 sexps 78 77 79 78 (** Find source field: (source ...) *) 80 80 - let find_source sexps = 79 79 + let source sexps = 81 80 List.find_map 82 81 (function 83 82 | Sexp.List [ Sexp.Atom "source"; inner ] -> parse_source_inner inner ··· 88 87 match Parsexp.Many.parse_string content with 89 88 | Error err -> 90 89 Error 91 91 - (Printf.sprintf "S-expression parse error: %s" 90 90 + (Fmt.str "S-expression parse error: %s" 92 91 (Parsexp.Parse_error.message err)) 93 92 | Ok sexps -> ( 94 94 - match find_string_field "name" sexps with 93 93 + match string_field "name" sexps with 95 94 | None -> Error "dune-project missing (name ...) stanza" 96 95 | Some name -> 97 97 - let source = find_source sexps in 98 98 - let homepage = find_string_field "homepage" sexps in 96 96 + let source = source sexps in 97 97 + let homepage = string_field "homepage" sexps in 99 98 let packages = extract_packages sexps in 100 99 Ok { name; source; homepage; packages }) 101 100 ··· 115 114 let dev_repo_url t = 116 115 match t.source with 117 116 | Some (Github { user; repo }) -> 118 118 - Ok (Printf.sprintf "git+https://github.com/%s/%s.git" user repo) 117 117 + Ok (Fmt.str "git+https://github.com/%s/%s.git" user repo) 119 118 | Some (Gitlab { user; repo }) -> 120 120 - Ok (Printf.sprintf "git+https://gitlab.com/%s/%s.git" user repo) 119 119 + Ok (Fmt.str "git+https://gitlab.com/%s/%s.git" user repo) 121 120 | Some (Tangled { host; repo }) -> 122 121 (* Tangled sources: https://tangled.sh/@handle/repo *) 123 123 - Ok (Printf.sprintf "git+https://tangled.sh/@%s/%s.git" host repo) 122 122 + Ok (Fmt.str "git+https://tangled.sh/@%s/%s.git" host repo) 124 123 | Some (Uri { url; _ }) -> Ok (normalize_git_url (ensure_git_suffix url)) 125 124 | None -> ( 126 125 match t.homepage with 127 126 | Some homepage -> Ok (normalize_git_url (ensure_git_suffix homepage)) 128 127 | None -> 129 128 Error 130 130 - (Printf.sprintf 129 129 + (Fmt.str 131 130 "Package %s must declare source or homepage in dune-project" 132 131 t.name)) 133 132

+5 -7

lib/forks.ml

reviewed

··· 60 60 (* Create directory if needed *) 61 61 let dir = Filename.dirname path in 62 62 if not (Sys.file_exists dir) then 63 63 - ignore (Sys.command (Printf.sprintf "mkdir -p %s" (Filename.quote dir))); 63 63 + ignore (Sys.command (Fmt.str "mkdir -p %s" (Filename.quote dir))); 64 64 (* Write cache as JSON *) 65 65 Out_channel.with_open_text path (fun oc -> 66 66 output_string oc "{\n"; ··· 69 69 (fun key ts -> 70 70 if not !first then output_string oc ",\n"; 71 71 first := false; 72 72 - Printf.fprintf oc " \"%s\": %.0f" key ts) 72 72 + output_string oc (Fmt.str " \"%s\": %.0f" key ts)) 73 73 fetch_cache; 74 74 output_string oc "\n}\n") 75 75 with Sys_error msg -> ··· 144 144 try 145 145 let dir = Filename.dirname path in 146 146 if not (Sys.file_exists dir) then 147 147 - ignore (Sys.command (Printf.sprintf "mkdir -p %s" (Filename.quote dir))); 147 147 + ignore (Sys.command (Fmt.str "mkdir -p %s" (Filename.quote dir))); 148 148 Out_channel.with_open_text path (fun oc -> 149 149 Hashtbl.iter 150 150 (fun key pairs -> ··· 459 459 let opamfile = 460 460 OpamParser.FullPos.string content (Fpath.to_string opam_path) 461 461 in 462 462 - match Opam_repo.find_dev_repo opamfile.file_contents with 462 462 + match Opam_repo.dev_repo opamfile.file_contents with 463 463 | None -> None 464 464 | Some url_str -> 465 465 if Opam_repo.is_git_url url_str then ··· 596 596 597 597 (** Fetch a remote (with caching) *) 598 598 let fetch_remote ~proc ~fs ~repo ~remote ~refresh () = 599 599 - let cache_key = 600 600 - Printf.sprintf "checkout/%s/%s" (Fpath.to_string repo) remote 601 601 - in 599 599 + let cache_key = Fmt.str "checkout/%s/%s" (Fpath.to_string repo) remote in 602 600 if not (needs_fetch ~refresh ~timeout:default_cache_timeout cache_key) then begin 603 601 Log.debug (fun m -> 604 602 m "Skipping fetch for %s in %a (cached)" remote Fpath.pp repo);

+5

lib/forks.mli

reviewed

··· 36 36 (** {1 Pretty Printing} *) 37 37 38 38 val pp_relationship : relationship Fmt.t 39 39 + (** Pretty-print a relationship. *) 40 40 + 39 41 val pp_repo_source : repo_source Fmt.t 42 42 + (** Pretty-print a repository source. *) 43 43 + 40 44 val pp_repo_analysis : repo_analysis Fmt.t 45 45 + (** Pretty-print a repository analysis. *) 41 46 42 47 val pp : t Fmt.t 43 48 (** Verbose output with full URLs for each repo. *)

+10 -14

lib/monopam.ml

reviewed

··· 161 161 162 162 (** Find opam files in monorepo subtrees that aren't registered in the overlay. 163 163 Returns a list of (subtree_name, unregistered_package_name) pairs. *) 164 164 - let find_unregistered_opam_files ~fs ~config pkgs = 164 164 + let unregistered_opam_files ~fs ~config pkgs = 165 165 let fs = fs_typed fs in 166 166 let monorepo = Config.Paths.monorepo config in 167 167 let registered_by_repo = Hashtbl.create 16 in ··· 281 281 else dev_repo 282 282 in 283 283 let repo_cell = 284 284 - if i = 0 then Printf.sprintf "[**%s**](%s)" repo display_url else "" 284 284 + if i = 0 then Fmt.str "[**%s**](%s)" repo display_url else "" 285 285 in 286 286 let synopsis = Option.value ~default:"" (Package.synopsis pkg) in 287 287 Buffer.add_string buf 288 288 - (Printf.sprintf "| %s | %s | %s |\n" repo_cell (Package.name pkg) 289 289 - synopsis)) 288 288 + (Fmt.str "| %s | %s | %s |\n" repo_cell (Package.name pkg) synopsis)) 290 289 pkgs) 291 290 grouped; 292 291 Buffer.add_string buf "\n---\n\n"; 293 292 Buffer.add_string buf 294 294 - (Printf.sprintf 295 295 - "_Generated by monopam. %d packages from %d repositories._\n" 293 293 + (Fmt.str "_Generated by monopam. %d packages from %d repositories._\n" 296 294 (List.length pkgs) (List.length grouped)); 297 295 Buffer.contents buf 298 296 ··· 467 465 Buffer.add_string buf " (allow_empty)\n"; 468 466 Buffer.add_string buf " (depends\n"; 469 467 List.iter 470 470 - (fun dep -> Buffer.add_string buf (Printf.sprintf " %s\n" dep)) 468 468 + (fun dep -> Buffer.add_string buf (Fmt.str " %s\n" dep)) 471 469 external_deps; 472 470 Buffer.add_string buf " ))\n"; 473 471 Buffer.contents buf ··· 681 679 String.sub path 1 (String.length path - 1) 682 680 else path 683 681 in 684 684 - Printf.sprintf "git@github.com:%s" path 682 682 + Fmt.str "git@github.com:%s" path 685 683 | Some ("https" | "http"), _ when is_tangled_host host -> 686 684 (* https://tangled.org/@handle/repo -> git@<knot>:handle/repo *) 687 685 let path = ··· 703 701 in 704 702 (* Use provided knot or default to git.recoil.org *) 705 703 let knot_server = Option.value ~default:"git.recoil.org" knot in 706 706 - Printf.sprintf "git@%s:%s" knot_server path 704 704 + Fmt.str "git@%s:%s" knot_server path 707 705 | _ -> 708 706 (* Return original URL for other cases *) 709 707 Uri.to_string uri ··· 719 717 String.sub path 0 (String.length path - 1) 720 718 else path 721 719 in 722 722 - Printf.sprintf "%s://%s%s" scheme host path 720 720 + Fmt.str "%s://%s%s" scheme host path 723 721 724 722 (* Deduplicate packages by dev-repo, keeping first occurrence of each repo *) 725 723 let unique_repos pkgs = ··· 2219 2217 (* First, find the commit *) 2220 2218 match diff_show_commit ~proc ~fs ~config ~verse_config ~sha ~refresh () with 2221 2219 | None -> 2222 2222 - Error 2223 2223 - (Config_error 2224 2224 - (Printf.sprintf "Commit %s not found in any verse diff" sha)) 2220 2220 + Error (Config_error (Fmt.str "Commit %s not found in any verse diff" sha)) 2225 2221 | Some info -> 2226 2222 let checkout_path = Fpath.(checkouts_path / info.commit_repo) in 2227 2223 if not (Git.Repository.is_repo ~fs checkout_path) then 2228 2224 Error 2229 2225 (Config_error 2230 2230 - (Printf.sprintf "No checkout for repository %s" info.commit_repo)) 2226 2226 + (Fmt.str "No checkout for repository %s" info.commit_repo)) 2231 2227 else begin 2232 2228 let git_repo = Git.Repository.open_repo ~fs checkout_path in 2233 2229 match Git.Repository.cherry_pick git_repo ~commit:info.commit_hash with

+2 -2

lib/monopam.mli

reviewed

··· 254 254 @param config Monopam configuration 255 255 @param name Package name to find *) 256 256 257 257 - val find_unregistered_opam_files : 257 257 + val unregistered_opam_files : 258 258 fs:Eio.Fs.dir_ty Eio.Path.t -> 259 259 config:Config.t -> 260 260 Package.t list -> 261 261 (string * string) list 262 262 - (** [find_unregistered_opam_files ~fs ~config pkgs] finds opam files in monorepo 262 262 + (** [unregistered_opam_files ~fs ~config pkgs] finds opam files in monorepo 263 263 subtree directories that aren't registered in the opam overlay. 264 264 265 265 Returns a list of [(repo_name, package_name)] pairs for each unregistered

+11

lib/monorepo_pkg.mli

reviewed

··· 9 9 } 10 10 11 11 val name : t -> string 12 12 + (** Package name from the opam file. *) 13 13 + 12 14 val subtree : t -> string 15 15 + (** Subtree directory name within the monorepo. *) 16 16 + 13 17 val dev_repo : t -> string 18 18 + (** Development repository URL. *) 19 19 + 14 20 val url_src : t -> string 21 21 + (** Source URL for releases. *) 22 22 + 15 23 val opam_content : t -> string 24 24 + (** Raw content of the opam file. *) 16 25 17 26 val discover : 18 27 fs:Eio.Fs.dir_ty Eio.Path.t -> ··· 20 29 ?sources:Sources_registry.t -> 21 30 unit -> 22 31 (t list, [> `Config_error of string ]) result 32 32 + (** [discover ~fs ~config ?sources ()] scans all subtrees in the monorepo for 33 33 + opam files and returns package metadata. *)

+7 -7

lib/opam_repo.ml

reviewed

··· 38 38 let extract_string_value (v : OP.value) : string option = 39 39 match v.pelem with OP.String s -> Some s | _ -> None 40 40 41 41 - let find_dev_repo (items : OP.opamfile_item list) : string option = 41 41 + let dev_repo (items : OP.opamfile_item list) : string option = 42 42 List.find_map 43 43 (fun (item : OP.opamfile_item) -> 44 44 match item.pelem with ··· 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 -> []) 68 68 69 69 - let find_depends (items : OP.opamfile_item list) : string list = 69 69 + let depends (items : OP.opamfile_item list) : string list = 70 70 List.find_map 71 71 (fun (item : OP.opamfile_item) -> 72 72 match item.pelem with ··· 76 76 items 77 77 |> Option.value ~default:[] 78 78 79 79 - let find_synopsis (items : OP.opamfile_item list) : string option = 79 79 + let synopsis (items : OP.opamfile_item list) : string option = 80 80 List.find_map 81 81 (fun (item : OP.opamfile_item) -> 82 82 match item.pelem with ··· 108 108 let eio_path = Eio.Path.(fs / path_str) in 109 109 let content = Eio.Path.load eio_path in 110 110 let opamfile = OpamParser.FullPos.string content path_str in 111 111 - match find_dev_repo opamfile.file_contents with 111 111 + match dev_repo opamfile.file_contents with 112 112 | None -> Error (No_dev_repo name) 113 113 | Some url -> 114 114 if not (is_git_url url) then Error (Not_git_remote (name, url)) 115 115 else 116 116 let dev_repo = normalize_git_url url in 117 117 - let depends = find_depends opamfile.file_contents in 118 118 - let synopsis = find_synopsis opamfile.file_contents in 117 117 + let depends = depends opamfile.file_contents in 118 118 + let synopsis = synopsis opamfile.file_contents in 119 119 Ok (Package.create ~name ~version ~dev_repo ~depends ?synopsis ()) 120 120 with 121 121 | Eio.Io _ as e -> Error (Io_error (Printexc.to_string e)) ··· 180 180 OpamParser.FullPos.string content 181 181 (Fpath.to_string dir_path ^ "/" ^ opam_file) 182 182 in 183 183 - find_depends opamfile.file_contents 183 183 + depends opamfile.file_contents 184 184 with Eio.Io _ | Parsing.Parse_error -> []) 185 185 opam_files 186 186 with Eio.Io _ -> []

+2 -3

lib/opam_repo.mli

reviewed

··· 89 89 90 90 (** {1 Low-level Opam File Parsing} *) 91 91 92 92 - val find_dev_repo : OpamParserTypes.FullPos.opamfile_item list -> string option 93 93 - (** [find_dev_repo items] extracts the dev-repo field from parsed opam file 94 94 - items. *) 92 92 + val dev_repo : OpamParserTypes.FullPos.opamfile_item list -> string option 93 93 + (** [dev_repo items] extracts the dev-repo field from parsed opam file items. *) 95 94 96 95 (** {1 Writing Packages} *) 97 96

+4

lib/opam_sync.mli

reviewed

··· 8 8 } 9 9 10 10 val pp : t Fmt.t 11 11 + (** Pretty-print sync results. *) 11 12 12 13 val run : 13 14 fs:Eio.Fs.dir_ty Eio.Path.t -> ··· 15 16 ?packages:string list -> 16 17 unit -> 17 18 (t, [> `Config_error of string ]) result 19 19 + (** [run ~fs ~config ?packages ()] syncs opam files from monorepo subtrees to 20 20 + the local opam-repo. If [packages] is specified, only syncs those packages. 21 21 + *)

+4 -4

lib/remote_cache.ml

reviewed

··· 27 27 type t = { tbl : (string, entry) Hashtbl.t; ttl : float; now : unit -> float } 28 28 29 29 let default_ttl = 300.0 (* 5 minutes *) 30 30 - let make_key url branch = Fmt.str "%s:%s" (Uri.to_string url) branch 30 30 + let key url branch = Fmt.str "%s:%s" (Uri.to_string url) branch 31 31 32 32 let parse_line ~ttl line = 33 33 match String.split_on_char ' ' line with ··· 62 62 let tbl = Hashtbl.create 32 in 63 63 { tbl; ttl; now } 64 64 65 65 - let create_from_string ?(ttl = default_ttl) ~now content = 65 65 + let from_string ?(ttl = default_ttl) ~now content = 66 66 let tbl = load_from_string ~ttl content in 67 67 { tbl; ttl; now } 68 68 69 69 let get t ~url ~branch = 70 70 - let key = make_key url branch in 70 70 + let key = key url branch in 71 71 let now = t.now () in 72 72 match Hashtbl.find_opt t.tbl key with 73 73 | Some entry when entry.expires > now -> ··· 83 83 None 84 84 85 85 let set t ~url ~branch ~hash = 86 86 - let key = make_key url branch in 86 86 + let key = key url branch in 87 87 let expires = t.now () +. t.ttl in 88 88 Hashtbl.replace t.tbl key { hash; expires } 89 89

+3 -3

lib/remote_cache.mli

reviewed

··· 48 48 @param ttl Time-to-live in seconds (default {!default_ttl}) 49 49 @param now Function to get current time in seconds *) 50 50 51 51 - val create_from_string : ?ttl:float -> now:(unit -> float) -> string -> t 52 52 - (** [create_from_string ~ttl ~now content] creates a cache populated from 53 53 - serialized content. 51 51 + val from_string : ?ttl:float -> now:(unit -> float) -> string -> t 52 52 + (** [from_string ~ttl ~now content] creates a cache populated from serialized 53 53 + content. 54 54 55 55 @param ttl Time-to-live in seconds (default {!default_ttl}) 56 56 @param now Function to get current time in seconds

+57 -61

lib/site.ml

reviewed

··· 295 295 let format_relationship = function 296 296 | Forks.Same_url -> "=" 297 297 | Forks.Same_commit -> "sync" 298 298 - | Forks.I_am_ahead n -> Printf.sprintf "+%d" n 299 299 - | Forks.I_am_behind n -> Printf.sprintf "-%d" n 298 298 + | Forks.I_am_ahead n -> Fmt.str "+%d" n 299 299 + | Forks.I_am_behind n -> Fmt.str "-%d" n 300 300 | Forks.Diverged { my_ahead; their_ahead; _ } -> 301 301 - Printf.sprintf "+%d/-%d" my_ahead their_ahead 301 301 + Fmt.str "+%d/-%d" my_ahead their_ahead 302 302 | Forks.Unrelated -> "unrel" 303 303 | Forks.Not_fetched -> "?" 304 304 ··· 360 360 let add = Buffer.add_string buf in 361 361 add "<div class=\"member\">\n"; 362 362 add 363 363 - (Printf.sprintf 364 364 - "<div class=\"member-name\"><a href=\"https://%s\">%s</a></div>\n" 363 363 + (Fmt.str "<div class=\"member-name\"><a href=\"https://%s\">%s</a></div>\n" 365 364 (html_escape m.handle) 366 365 (html_escape m.display_name)); 367 366 if m.display_name <> m.handle then 368 367 add 369 369 - (Printf.sprintf "<div class=\"member-handle\">%s</div>\n" 370 370 - (html_escape m.handle)); 371 371 - add (Printf.sprintf "<div class=\"member-stats\">%d packages" m.package_count); 368 368 + (Fmt.str "<div class=\"member-handle\">%s</div>\n" (html_escape m.handle)); 369 369 + add (Fmt.str "<div class=\"member-stats\">%d packages" m.package_count); 372 370 if m.unique_packages <> [] then 373 373 - add (Printf.sprintf ", %d unique" (List.length m.unique_packages)); 371 371 + add (Fmt.str ", %d unique" (List.length m.unique_packages)); 374 372 add "</div>\n"; 375 373 if m.monorepo_url <> "" || m.opam_url <> "" then begin 376 374 add "<div class=\"member-links\">"; 377 375 if m.monorepo_url <> "" then 378 376 add 379 379 - (Printf.sprintf "<a class=\"ext\" href=\"%s\">mono%s</a>" 377 377 + (Fmt.str "<a class=\"ext\" href=\"%s\">mono%s</a>" 380 378 (html_escape m.monorepo_url) 381 379 external_link_icon); 382 380 if m.opam_url <> "" then 383 381 add 384 384 - (Printf.sprintf "<a class=\"ext\" href=\"%s\">opam%s</a>" 382 382 + (Fmt.str "<a class=\"ext\" href=\"%s\">opam%s</a>" 385 383 (html_escape m.opam_url) external_link_icon); 386 384 add "</div>\n" 387 385 end; 388 386 add "</div>\n" 389 387 388 388 + let fork_status_class = function 389 389 + | Forks.Same_url | Forks.Same_commit -> "sync" 390 390 + | Forks.I_am_ahead _ -> "ahead" 391 391 + | Forks.I_am_behind _ -> "behind" 392 392 + | Forks.Diverged _ -> "diverged" 393 393 + | _ -> "" 394 394 + 395 395 + let format_fork_status rel = 396 396 + let status_str = format_relationship rel in 397 397 + let status_class = fork_status_class rel in 398 398 + if status_class <> "" then 399 399 + Fmt.str "<span class=\"fork-status %s\">%s</span>" status_class status_str 400 400 + else Fmt.str "<span class=\"fork-status\">%s</span>" status_str 401 401 + 402 402 + let generate_fork_item buf ~member_urls ~get_name ~ri_name ~fork_status handle = 403 403 + let add = Buffer.add_string buf in 404 404 + let mono_url, _ = 405 405 + try Hashtbl.find member_urls handle with Not_found -> ("", "") 406 406 + in 407 407 + add "<span class=\"fork-item\">"; 408 408 + add 409 409 + (Fmt.str "<a href=\"https://%s\">%s</a>" (html_escape handle) 410 410 + (html_escape (get_name handle))); 411 411 + Option.iter 412 412 + (fun rel -> add (format_fork_status rel)) 413 413 + (List.assoc_opt handle fork_status); 414 414 + if mono_url <> "" then 415 415 + add 416 416 + (Fmt.str "<a class=\"ext\" href=\"%s/%s\">mono%s</a>" 417 417 + (html_escape mono_url) (html_escape ri_name) external_link_icon); 418 418 + add "</span>\n" 419 419 + 390 420 (** Generate repo detail HTML *) 391 421 let generate_repo_detail buf ~member_urls ~get_name r = 392 422 let add = Buffer.add_string buf in 393 393 - add 394 394 - (Printf.sprintf "<div class=\"repo\" id=\"%s\">\n" (html_escape r.ri_name)); 423 423 + add (Fmt.str "<div class=\"repo\" id=\"%s\">\n" (html_escape r.ri_name)); 395 424 add "<div class=\"repo-header\">"; 396 425 add 397 397 - (Printf.sprintf 426 426 + (Fmt.str 398 427 "<span class=\"repo-name\"><a class=\"ext\" href=\"%s\">%s%s</a></span>" 399 428 (html_escape r.ri_dev_repo) 400 429 (html_escape r.ri_name) external_link_icon); ··· 416 445 List.iter 417 446 (fun (name, desc) -> 418 447 add 419 419 - (Printf.sprintf "<li><b>%s</b>: %s</li>\n" (html_escape name) 448 448 + (Fmt.str "<li><b>%s</b>: %s</li>\n" (html_escape name) 420 449 (html_escape desc))) 421 450 pkg_descs; 422 451 add "</ul>\n" ··· 426 455 let owner_links = 427 456 List.map 428 457 (fun h -> 429 429 - Printf.sprintf "<a href=\"https://%s\">%s</a>" (html_escape h) 458 458 + Fmt.str "<a href=\"https://%s\">%s</a>" (html_escape h) 430 459 (html_escape (get_name h))) 431 460 (List.sort String.compare r.ri_owners) 432 461 in 433 462 add "<details class=\"repo-forks\">\n"; 434 463 add 435 435 - (Printf.sprintf "<summary>%d members (%s)</summary>\n" 436 436 - (List.length r.ri_owners) 464 464 + (Fmt.str "<summary>%d members (%s)</summary>\n" (List.length r.ri_owners) 437 465 (String.concat ", " owner_links)); 438 466 add "<div class=\"fork-list\">\n"; 439 467 List.iter 440 440 - (fun handle -> 441 441 - let mono_url, _opam_url = 442 442 - try Hashtbl.find member_urls handle with Not_found -> ("", "") 443 443 - in 444 444 - add "<span class=\"fork-item\">"; 445 445 - add 446 446 - (Printf.sprintf "<a href=\"https://%s\">%s</a>" (html_escape handle) 447 447 - (html_escape (get_name handle))); 448 448 - (match List.assoc_opt handle r.ri_fork_status with 449 449 - | Some rel -> 450 450 - let status_str = format_relationship rel in 451 451 - let status_class = 452 452 - match rel with 453 453 - | Forks.Same_url | Forks.Same_commit -> "sync" 454 454 - | Forks.I_am_ahead _ -> "ahead" 455 455 - | Forks.I_am_behind _ -> "behind" 456 456 - | Forks.Diverged _ -> "diverged" 457 457 - | _ -> "" 458 458 - in 459 459 - if status_class <> "" then 460 460 - add 461 461 - (Printf.sprintf "<span class=\"fork-status %s\">%s</span>" 462 462 - status_class status_str) 463 463 - else 464 464 - add 465 465 - (Printf.sprintf "<span class=\"fork-status\">%s</span>" 466 466 - status_str) 467 467 - | None -> ()); 468 468 - if mono_url <> "" then 469 469 - add 470 470 - (Printf.sprintf "<a class=\"ext\" href=\"%s/%s\">mono%s</a>" 471 471 - (html_escape mono_url) (html_escape r.ri_name) external_link_icon); 472 472 - add "</span>\n") 468 468 + (generate_fork_item buf ~member_urls ~get_name ~ri_name:r.ri_name 469 469 + ~fork_status:r.ri_fork_status) 473 470 (List.sort String.compare r.ri_owners); 474 471 add "</div>\n</details>\n" 475 472 end; ··· 496 493 add "<meta charset=\"UTF-8\">\n"; 497 494 add 498 495 "<meta name=\"viewport\" content=\"width=device-width, initial-scale=1.0\">\n"; 499 499 - add (Printf.sprintf "<title>%s</title>\n" (html_escape data.registry_name)); 496 496 + add (Fmt.str "<title>%s</title>\n" (html_escape data.registry_name)); 500 497 add "<style>\n"; 501 498 add site_css; 502 499 add "\n</style>\n</head>\n<body>\n"; 503 500 504 504 - add (Printf.sprintf "<h1>%s</h1>\n" (html_escape data.registry_name)); 501 501 + add (Fmt.str "<h1>%s</h1>\n" (html_escape data.registry_name)); 505 502 (match data.registry_description with 506 503 | Some desc -> 507 507 - add 508 508 - (Printf.sprintf "<div class=\"subtitle\">%s</div>\n" (html_escape desc)) 504 504 + add (Fmt.str "<div class=\"subtitle\">%s</div>\n" (html_escape desc)) 509 505 | None -> add "<div class=\"subtitle\"></div>\n"); 510 506 511 507 add ··· 527 523 528 524 add "<div class=\"section\">\n<div class=\"summary\">\n"; 529 525 add 530 530 - (Printf.sprintf 526 526 + (Fmt.str 531 527 "<div class=\"summary-title\">Common Libraries (%d repos, %d \ 532 528 packages)</div>\n" 533 529 (List.length data.common_repos) ··· 538 534 List.iter 539 535 (fun r -> 540 536 add 541 541 - (Printf.sprintf 537 537 + (Fmt.str 542 538 "<span class=\"summary-item\"><a href=\"#%s\">%s</a> <span \ 543 539 style=\"color:#888\">(%d)</span></span>\n" 544 540 (html_escape r.ri_name) (html_escape r.ri_name) ··· 557 553 (fun m -> 558 554 add "<div class=\"unique-member\">\n"; 559 555 add 560 560 - (Printf.sprintf 556 556 + (Fmt.str 561 557 "<span class=\"unique-member-name\"><a \ 562 558 href=\"https://%s\">%s</a>:</span> " 563 559 (html_escape m.handle) ··· 581 577 let now = Unix.gettimeofday () in 582 578 let tm = Unix.gmtime now in 583 579 let date_str = 584 584 - Printf.sprintf "%04d-%02d-%02d" (tm.Unix.tm_year + 1900) 585 585 - (tm.Unix.tm_mon + 1) tm.Unix.tm_mday 580 580 + Fmt.str "%04d-%02d-%02d" (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) 581 581 + tm.Unix.tm_mday 586 582 in 587 583 add 588 588 - (Printf.sprintf 584 584 + (Fmt.str 589 585 "<footer>Generated by monopam on %s | %d members | %d repos | %d \ 590 586 packages</footer>\n" 591 587 date_str (List.length data.members)

+6 -12

lib/status.ml

reviewed

··· 330 330 let local_status_span t = 331 331 match (t.checkout, t.subtree, t.subtree_sync) with 332 332 | Clean _, Present, Subtree_behind n -> 333 333 - Tty.Span.styled Tty.Style.(fg Tty.Color.blue) (Printf.sprintf "-%d" n) 333 333 + Tty.Span.styled Tty.Style.(fg Tty.Color.blue) (Fmt.str "-%d" n) 334 334 | Clean _, Present, Subtree_ahead n -> 335 335 - Tty.Span.styled Tty.Style.(fg Tty.Color.blue) (Printf.sprintf "+%d" n) 335 335 + Tty.Span.styled Tty.Style.(fg Tty.Color.blue) (Fmt.str "+%d" n) 336 336 | Clean _, Present, Trees_differ -> 337 337 Tty.Span.styled Tty.Style.(fg Tty.Color.blue) "sync" 338 338 | Clean _, Present, (In_sync | Unknown) -> ··· 349 349 | Clean ab when ab.ahead > 0 && ab.behind > 0 -> 350 350 Tty.Span.styled 351 351 Tty.Style.(fg Tty.Color.yellow) 352 352 - (Printf.sprintf "+%d/-%d" ab.ahead ab.behind) 352 352 + (Fmt.str "+%d/-%d" ab.ahead ab.behind) 353 353 | Clean ab when ab.ahead > 0 -> 354 354 - Tty.Span.styled 355 355 - Tty.Style.(fg Tty.Color.cyan) 356 356 - (Printf.sprintf "+%d" ab.ahead) 354 354 + Tty.Span.styled Tty.Style.(fg Tty.Color.cyan) (Fmt.str "+%d" ab.ahead) 357 355 | Clean ab when ab.behind > 0 -> 358 358 - Tty.Span.styled 359 359 - Tty.Style.(fg Tty.Color.red) 360 360 - (Printf.sprintf "-%d" ab.behind) 356 356 + Tty.Span.styled Tty.Style.(fg Tty.Color.red) (Fmt.str "-%d" ab.behind) 361 357 | Clean _ -> Tty.Span.styled Tty.Style.(fg Tty.Color.green) "=" 362 358 | Missing | Not_a_repo | Dirty -> Tty.Span.text "-" 363 359 ··· 381 377 let abbrev = 382 378 if String.length abbrev > 8 then String.sub abbrev 0 8 else abbrev 383 379 in 384 384 - Tty.Span.styled 385 385 - Tty.Style.(fg Tty.Color.cyan) 386 386 - (Printf.sprintf "v:%s" abbrev) 380 380 + Tty.Span.styled Tty.Style.(fg Tty.Color.cyan) (Fmt.str "v:%s" abbrev) 387 381 | None -> Tty.Span.styled Tty.Style.(fg Tty.Color.cyan) "v:") 388 382 | Some Sources_registry.{ origin = Some Sources_registry.Join; _ } -> 389 383 Tty.Span.styled Tty.Style.(fg Tty.Color.cyan) "v:"

+7

lib/sync_progress.mli

reviewed

··· 52 52 type t 53 53 54 54 val create : total:int -> string -> t 55 55 + (** Create progress for a phase with the given total item count. *) 56 56 + 55 57 val tick : t -> string -> unit 58 58 + (** Increment progress and update the displayed message. *) 59 59 + 56 60 val clear : t -> unit 61 61 + (** Clear the progress line without printing a newline. *) 62 62 + 57 63 val finish : t -> unit 64 64 + (** Complete the progress bar and print a newline. *) 58 65 end 59 66 60 67 module Active : S with type t = t

+17 -16

lib/verse.ml

reviewed

··· 402 402 && is_directory ~fs Fpath.(monorepo_path / name)) 403 403 with Eio.Io _ -> [] 404 404 405 405 + let add_subtrees_to_map subtree_map handle member_mono subtrees = 406 406 + List.iter 407 407 + (fun subtree -> 408 408 + let existing = 409 409 + try Hashtbl.find subtree_map subtree with Not_found -> [] 410 410 + in 411 411 + Hashtbl.replace subtree_map subtree ((handle, member_mono) :: existing)) 412 412 + subtrees 413 413 + 414 414 + let scan_member_subtrees ~fs subtree_map verse_path handle = 415 415 + let member_mono = Fpath.(verse_path / handle) in 416 416 + if Git.Repository.is_repo ~fs member_mono then begin 417 417 + let subtrees = scan_subtrees ~fs member_mono in 418 418 + add_subtrees_to_map subtree_map handle member_mono subtrees 419 419 + end 420 420 + 405 421 (** Get subtrees from all tracked verse members. Returns a map from subtree name 406 422 to list of (handle, monorepo_path) pairs. *) 407 423 let verse_subtrees ~fs ~config () = 408 424 let verse_path = Verse_config.verse_path config in 409 425 let tracked_handles = tracked_handles ~fs config in 410 410 - (* Build map: subtree_name -> [(handle, monorepo_path)] *) 411 426 let subtree_map = Hashtbl.create 64 in 412 412 - List.iter 413 413 - (fun handle -> 414 414 - let member_mono = Fpath.(verse_path / handle) in 415 415 - if Git.Repository.is_repo ~fs member_mono then begin 416 416 - let subtrees = scan_subtrees ~fs member_mono in 417 417 - List.iter 418 418 - (fun subtree -> 419 419 - let existing = 420 420 - try Hashtbl.find subtree_map subtree with Not_found -> [] 421 421 - in 422 422 - Hashtbl.replace subtree_map subtree 423 423 - ((handle, member_mono) :: existing)) 424 424 - subtrees 425 425 - end) 426 426 - tracked_handles; 427 427 + List.iter (scan_member_subtrees ~fs subtree_map verse_path) tracked_handles; 427 428 subtree_map 428 429 429 430 type fork_result = {

+2 -2

test/dune

reviewed

··· 1 1 (test 2 2 - (name test_remote_cache) 3 3 - (libraries monopam alcotest uri)) 2 2 + (name test_monopam) 3 3 + (libraries monopam alcotest fpath uri)) 4 4 5 5 (cram 6 6 (deps %{bin:monopam}))

+160

test/test_config.ml

reviewed

··· 1 1 + (* Tests for Config module *) 2 2 + 3 3 + module Config = Monopam.Config 4 4 + 5 5 + let fpath = Alcotest.testable Fpath.pp Fpath.equal 6 6 + 7 7 + (* Test config creation and accessors *) 8 8 + 9 9 + let test_create_basic () = 10 10 + let root = Fpath.v "/home/user/workspace" in 11 11 + let config = Config.create ~root ~handle:"anil.recoil.org" () in 12 12 + Alcotest.(check string) "handle" "anil.recoil.org" (Config.handle config); 13 13 + Alcotest.check fpath "root" root (Config.root config) 14 14 + 15 15 + let test_create_with_knot () = 16 16 + let root = Fpath.v "/home/user/workspace" in 17 17 + let config = 18 18 + Config.create ~root ~handle:"anil.recoil.org" ~knot:"git.example.com" () 19 19 + in 20 20 + Alcotest.(check string) "knot" "git.example.com" (Config.knot config) 21 21 + 22 22 + let test_default_knot_derivation () = 23 23 + let root = Fpath.v "/home/user/workspace" in 24 24 + let config = Config.create ~root ~handle:"anil.recoil.org" () in 25 25 + (* Default knot should be derived from handle: anil.recoil.org -> git.recoil.org *) 26 26 + Alcotest.(check string) "derived knot" "git.recoil.org" (Config.knot config) 27 27 + 28 28 + let test_default_knot_no_dot () = 29 29 + let root = Fpath.v "/home/user/workspace" in 30 30 + let config = Config.create ~root ~handle:"localuser" () in 31 31 + (* Fallback when no dot in handle *) 32 32 + Alcotest.(check string) "fallback knot" "git.localuser" (Config.knot config) 33 33 + 34 34 + (* Test paths *) 35 35 + 36 36 + let test_default_paths () = 37 37 + let paths = Config.default_paths in 38 38 + Alcotest.(check string) "default mono" "mono" paths.mono; 39 39 + Alcotest.(check string) "default src" "src" paths.src; 40 40 + Alcotest.(check string) "default verse" "verse" paths.verse 41 41 + 42 42 + let test_derived_paths () = 43 43 + let root = Fpath.v "/home/user/workspace" in 44 44 + let config = Config.create ~root ~handle:"test.example.org" () in 45 45 + Alcotest.check fpath "mono_path" 46 46 + (Fpath.v "/home/user/workspace/mono") 47 47 + (Config.mono_path config); 48 48 + Alcotest.check fpath "src_path" 49 49 + (Fpath.v "/home/user/workspace/src") 50 50 + (Config.src_path config); 51 51 + Alcotest.check fpath "opam_repo_path" 52 52 + (Fpath.v "/home/user/workspace/opam-repo") 53 53 + (Config.opam_repo_path config); 54 54 + Alcotest.check fpath "verse_path" 55 55 + (Fpath.v "/home/user/workspace/verse") 56 56 + (Config.verse_path config) 57 57 + 58 58 + let test_custom_paths () = 59 59 + let root = Fpath.v "/home/user/workspace" in 60 60 + let paths = { Config.mono = "."; src = "checkouts"; verse = "others" } in 61 61 + let config = Config.create ~root ~handle:"test.example.org" ~paths () in 62 62 + Alcotest.check fpath "custom mono_path" 63 63 + (Fpath.v "/home/user/workspace/.") 64 64 + (Config.mono_path config); 65 65 + Alcotest.check fpath "custom src_path" 66 66 + (Fpath.v "/home/user/workspace/checkouts") 67 67 + (Config.src_path config); 68 68 + Alcotest.check fpath "custom verse_path" 69 69 + (Fpath.v "/home/user/workspace/others") 70 70 + (Config.verse_path config) 71 71 + 72 72 + (* Test backwards compatibility aliases *) 73 73 + 74 74 + let test_paths_module_aliases () = 75 75 + let root = Fpath.v "/home/user/workspace" in 76 76 + let config = Config.create ~root ~handle:"test.example.org" () in 77 77 + Alcotest.check fpath "Paths.monorepo = mono_path" (Config.mono_path config) 78 78 + (Config.Paths.monorepo config); 79 79 + Alcotest.check fpath "Paths.checkouts = src_path" (Config.src_path config) 80 80 + (Config.Paths.checkouts config); 81 81 + Alcotest.check fpath "Paths.opam_repo = opam_repo_path" 82 82 + (Config.opam_repo_path config) 83 83 + (Config.Paths.opam_repo config) 84 84 + 85 85 + (* Test package overrides *) 86 86 + 87 87 + let test_no_package_overrides () = 88 88 + let root = Fpath.v "/home/user/workspace" in 89 89 + let config = Config.create ~root ~handle:"test.example.org" () in 90 90 + Alcotest.(check (list (pair string pass))) 91 91 + "empty packages" [] (Config.packages config); 92 92 + Alcotest.(check (option pass)) 93 93 + "no override" None 94 94 + (Config.package_config config "nonexistent") 95 95 + 96 96 + let test_with_package_override () = 97 97 + let root = Fpath.v "/home/user/workspace" in 98 98 + let config = Config.create ~root ~handle:"test.example.org" () in 99 99 + let config' = 100 100 + Config.with_package_override config ~name:"my-pkg" ~branch:"feature" () 101 101 + in 102 102 + Alcotest.(check int) "one override" 1 (List.length (Config.packages config')); 103 103 + match Config.package_config config' "my-pkg" with 104 104 + | None -> Alcotest.fail "expected package config" 105 105 + | Some pkg_config -> 106 106 + Alcotest.(check (option string)) 107 107 + "branch override" (Some "feature") 108 108 + (Config.Package_config.branch pkg_config) 109 109 + 110 110 + let test_override_update () = 111 111 + let root = Fpath.v "/home/user/workspace" in 112 112 + let config = Config.create ~root ~handle:"test.example.org" () in 113 113 + let config' = 114 114 + Config.with_package_override config ~name:"my-pkg" ~branch:"v1" () 115 115 + in 116 116 + let config'' = 117 117 + Config.with_package_override config' ~name:"my-pkg" ~branch:"v2" () 118 118 + in 119 119 + Alcotest.(check int) 120 120 + "still one override" 1 121 121 + (List.length (Config.packages config'')); 122 122 + match Config.package_config config'' "my-pkg" with 123 123 + | None -> Alcotest.fail "expected package config" 124 124 + | Some pkg_config -> 125 125 + Alcotest.(check (option string)) 126 126 + "updated branch" (Some "v2") 127 127 + (Config.Package_config.branch pkg_config) 128 128 + 129 129 + (* Test constants *) 130 130 + 131 131 + let test_default_branch () = 132 132 + Alcotest.(check string) "default branch is main" "main" Config.default_branch 133 133 + 134 134 + let suite = 135 135 + [ 136 136 + ( "Config: creation", 137 137 + [ 138 138 + Alcotest.test_case "basic" `Quick test_create_basic; 139 139 + Alcotest.test_case "with knot" `Quick test_create_with_knot; 140 140 + Alcotest.test_case "default knot derivation" `Quick 141 141 + test_default_knot_derivation; 142 142 + Alcotest.test_case "default knot no dot" `Quick test_default_knot_no_dot; 143 143 + ] ); 144 144 + ( "Config: paths", 145 145 + [ 146 146 + Alcotest.test_case "default paths" `Quick test_default_paths; 147 147 + Alcotest.test_case "derived paths" `Quick test_derived_paths; 148 148 + Alcotest.test_case "custom paths" `Quick test_custom_paths; 149 149 + Alcotest.test_case "Paths module aliases" `Quick 150 150 + test_paths_module_aliases; 151 151 + ] ); 152 152 + ( "Config: package_overrides", 153 153 + [ 154 154 + Alcotest.test_case "no overrides" `Quick test_no_package_overrides; 155 155 + Alcotest.test_case "with override" `Quick test_with_package_override; 156 156 + Alcotest.test_case "update override" `Quick test_override_update; 157 157 + ] ); 158 158 + ( "Config: constants", 159 159 + [ Alcotest.test_case "default branch" `Quick test_default_branch ] ); 160 160 + ]

+11

test/test_monopam.ml

reviewed

··· 1 1 + (* Main test runner for monopam *) 2 2 + 3 3 + let () = 4 4 + Alcotest.run "Monopam" 5 5 + (List.concat 6 6 + [ 7 7 + Test_config.suite; 8 8 + Test_package.suite; 9 9 + Test_status.suite; 10 10 + Test_remote_cache.suite; 11 11 + ])

+162

test/test_package.ml

reviewed

··· 1 1 + (* Tests for Package module *) 2 2 + 3 3 + module Package = Monopam.Package 4 4 + 5 5 + let fpath = Alcotest.testable Fpath.pp Fpath.equal 6 6 + let uri = Alcotest.testable Uri.pp Uri.equal 7 7 + 8 8 + (* Test package creation and accessors *) 9 9 + 10 10 + let test_create_basic () = 11 11 + let dev_repo = Uri.of_string "https://github.com/ocaml/ocaml.git" in 12 12 + let pkg = Package.create ~name:"ocaml" ~version:"dev" ~dev_repo () in 13 13 + Alcotest.(check string) "name" "ocaml" (Package.name pkg); 14 14 + Alcotest.(check string) "version" "dev" (Package.version pkg); 15 15 + Alcotest.check uri "dev_repo" dev_repo (Package.dev_repo pkg) 16 16 + 17 17 + let test_create_with_branch () = 18 18 + let dev_repo = Uri.of_string "https://github.com/ocaml/ocaml.git" in 19 19 + let pkg = 20 20 + Package.create ~name:"ocaml" ~version:"dev" ~dev_repo ~branch:"trunk" () 21 21 + in 22 22 + Alcotest.(check (option string)) "branch" (Some "trunk") (Package.branch pkg) 23 23 + 24 24 + let test_create_with_depends () = 25 25 + let dev_repo = Uri.of_string "https://github.com/example/mylib.git" in 26 26 + let pkg = 27 27 + Package.create ~name:"mylib" ~version:"dev" ~dev_repo 28 28 + ~depends:[ "base"; "stdio" ] () 29 29 + in 30 30 + Alcotest.(check (list string)) 31 31 + "depends" [ "base"; "stdio" ] (Package.depends pkg) 32 32 + 33 33 + let test_create_with_synopsis () = 34 34 + let dev_repo = Uri.of_string "https://github.com/example/mylib.git" in 35 35 + let pkg = 36 36 + Package.create ~name:"mylib" ~version:"dev" ~dev_repo 37 37 + ~synopsis:"A useful library" () 38 38 + in 39 39 + Alcotest.(check (option string)) 40 40 + "synopsis" (Some "A useful library") (Package.synopsis pkg) 41 41 + 42 42 + let test_default_values () = 43 43 + let dev_repo = Uri.of_string "https://github.com/example/mylib.git" in 44 44 + let pkg = Package.create ~name:"mylib" ~version:"dev" ~dev_repo () in 45 45 + Alcotest.(check (option string)) "default branch" None (Package.branch pkg); 46 46 + Alcotest.(check (list string)) "default depends" [] (Package.depends pkg); 47 47 + Alcotest.(check (option string)) 48 48 + "default synopsis" None (Package.synopsis pkg) 49 49 + 50 50 + (* Test repo_name extraction *) 51 51 + 52 52 + let test_repo_name_github () = 53 53 + let dev_repo = Uri.of_string "https://github.com/ocaml/ocaml.git" in 54 54 + let pkg = Package.create ~name:"ocaml" ~version:"dev" ~dev_repo () in 55 55 + Alcotest.(check string) "github repo name" "ocaml" (Package.repo_name pkg) 56 56 + 57 57 + let test_repo_name_no_git_suffix () = 58 58 + let dev_repo = Uri.of_string "https://github.com/ocaml/dune" in 59 59 + let pkg = Package.create ~name:"dune" ~version:"dev" ~dev_repo () in 60 60 + Alcotest.(check string) "no .git suffix" "dune" (Package.repo_name pkg) 61 61 + 62 62 + let test_repo_name_gitlab () = 63 63 + let dev_repo = Uri.of_string "https://gitlab.com/org/myrepo.git" in 64 64 + let pkg = Package.create ~name:"mylib" ~version:"dev" ~dev_repo () in 65 65 + Alcotest.(check string) "gitlab repo name" "myrepo" (Package.repo_name pkg) 66 66 + 67 67 + let test_repo_name_nested_path () = 68 68 + let dev_repo = Uri.of_string "https://github.com/org/sub/repo.git" in 69 69 + let pkg = Package.create ~name:"mylib" ~version:"dev" ~dev_repo () in 70 70 + Alcotest.(check string) "nested path" "repo" (Package.repo_name pkg) 71 71 + 72 72 + (* Test derived paths *) 73 73 + 74 74 + let test_checkout_dir () = 75 75 + let dev_repo = Uri.of_string "https://github.com/ocaml/ocaml.git" in 76 76 + let pkg = Package.create ~name:"ocaml" ~version:"dev" ~dev_repo () in 77 77 + let checkouts_root = Fpath.v "/home/user/src" in 78 78 + Alcotest.check fpath "checkout dir" 79 79 + (Fpath.v "/home/user/src/ocaml") 80 80 + (Package.checkout_dir ~checkouts_root pkg) 81 81 + 82 82 + let test_subtree_prefix () = 83 83 + let dev_repo = Uri.of_string "https://github.com/ocaml/ocaml.git" in 84 84 + let pkg = Package.create ~name:"ocaml" ~version:"dev" ~dev_repo () in 85 85 + Alcotest.(check string) "subtree prefix" "ocaml" (Package.subtree_prefix pkg) 86 86 + 87 87 + let test_multiple_packages_same_repo () = 88 88 + let dev_repo = Uri.of_string "https://github.com/mirage/mirage.git" in 89 89 + let pkg1 = Package.create ~name:"mirage" ~version:"dev" ~dev_repo () in 90 90 + let pkg2 = Package.create ~name:"mirage-unix" ~version:"dev" ~dev_repo () in 91 91 + Alcotest.(check string) 92 92 + "same repo name" (Package.repo_name pkg1) (Package.repo_name pkg2); 93 93 + Alcotest.(check string) 94 94 + "same subtree" 95 95 + (Package.subtree_prefix pkg1) 96 96 + (Package.subtree_prefix pkg2) 97 97 + 98 98 + (* Test comparison *) 99 99 + 100 100 + let test_compare () = 101 101 + let dev_repo = Uri.of_string "https://github.com/example/repo.git" in 102 102 + let pkg_a = Package.create ~name:"aaa" ~version:"dev" ~dev_repo () in 103 103 + let pkg_b = Package.create ~name:"bbb" ~version:"dev" ~dev_repo () in 104 104 + Alcotest.(check bool) "a < b" true (Package.compare pkg_a pkg_b < 0); 105 105 + Alcotest.(check bool) "b > a" true (Package.compare pkg_b pkg_a > 0); 106 106 + Alcotest.(check bool) "a = a" true (Package.compare pkg_a pkg_a = 0) 107 107 + 108 108 + let test_equal () = 109 109 + let dev_repo = Uri.of_string "https://github.com/example/repo.git" in 110 110 + let pkg1 = Package.create ~name:"test" ~version:"dev" ~dev_repo () in 111 111 + let pkg2 = Package.create ~name:"test" ~version:"1.0" ~dev_repo () in 112 112 + let pkg3 = Package.create ~name:"other" ~version:"dev" ~dev_repo () in 113 113 + Alcotest.(check bool) "same name equal" true (Package.equal pkg1 pkg2); 114 114 + Alcotest.(check bool) 115 115 + "different name not equal" false (Package.equal pkg1 pkg3) 116 116 + 117 117 + let test_same_repo () = 118 118 + let dev_repo1 = Uri.of_string "https://github.com/ocaml/ocaml.git" in 119 119 + let dev_repo2 = Uri.of_string "https://github.com/mirage/mirage.git" in 120 120 + let pkg1 = 121 121 + Package.create ~name:"ocaml" ~version:"dev" ~dev_repo:dev_repo1 () 122 122 + in 123 123 + let pkg2 = 124 124 + Package.create ~name:"ocaml-base" ~version:"dev" ~dev_repo:dev_repo1 () 125 125 + in 126 126 + let pkg3 = 127 127 + Package.create ~name:"mirage" ~version:"dev" ~dev_repo:dev_repo2 () 128 128 + in 129 129 + Alcotest.(check bool) "same repo" true (Package.same_repo pkg1 pkg2); 130 130 + Alcotest.(check bool) "different repo" false (Package.same_repo pkg1 pkg3) 131 131 + 132 132 + let suite = 133 133 + [ 134 134 + ( "Package: creation", 135 135 + [ 136 136 + Alcotest.test_case "basic" `Quick test_create_basic; 137 137 + Alcotest.test_case "with branch" `Quick test_create_with_branch; 138 138 + Alcotest.test_case "with depends" `Quick test_create_with_depends; 139 139 + Alcotest.test_case "with synopsis" `Quick test_create_with_synopsis; 140 140 + Alcotest.test_case "default values" `Quick test_default_values; 141 141 + ] ); 142 142 + ( "Package: repo_name", 143 143 + [ 144 144 + Alcotest.test_case "github" `Quick test_repo_name_github; 145 145 + Alcotest.test_case "no .git suffix" `Quick test_repo_name_no_git_suffix; 146 146 + Alcotest.test_case "gitlab" `Quick test_repo_name_gitlab; 147 147 + Alcotest.test_case "nested path" `Quick test_repo_name_nested_path; 148 148 + ] ); 149 149 + ( "Package: paths", 150 150 + [ 151 151 + Alcotest.test_case "checkout dir" `Quick test_checkout_dir; 152 152 + Alcotest.test_case "subtree prefix" `Quick test_subtree_prefix; 153 153 + Alcotest.test_case "multiple packages same repo" `Quick 154 154 + test_multiple_packages_same_repo; 155 155 + ] ); 156 156 + ( "Package: comparison", 157 157 + [ 158 158 + Alcotest.test_case "compare" `Quick test_compare; 159 159 + Alcotest.test_case "equal" `Quick test_equal; 160 160 + Alcotest.test_case "same_repo" `Quick test_same_repo; 161 161 + ] ); 162 162 + ]

+29 -31

test/test_remote_cache.ml

reviewed

··· 139 139 Remote_cache.set cache ~url:test_url ~branch:"develop" ~hash:"def456"; 140 140 let serialized = Remote_cache.to_string cache in 141 141 (* Reload from serialized *) 142 142 - let cache2 = Remote_cache.create_from_string ~now serialized in 142 142 + let cache2 = Remote_cache.from_string ~now serialized in 143 143 Alcotest.(check int) "size after reload" 2 (Remote_cache.size cache2); 144 144 Alcotest.(check (option string)) 145 145 "main after reload" (Some "abc123") ··· 160 160 let serialized = Remote_cache.to_string cache in 161 161 (* Reset time and reload *) 162 162 set 70.0; 163 163 - let cache2 = Remote_cache.create_from_string ~ttl ~now serialized in 163 163 + let cache2 = Remote_cache.from_string ~ttl ~now serialized in 164 164 (* Only the newer entry should survive *) 165 165 Alcotest.(check int) "only fresh entry" 1 (Remote_cache.size cache2); 166 166 Alcotest.(check (option string)) ··· 190 190 Alcotest.(check (float 0.1)) 191 191 "default ttl is 5 minutes" 300.0 Remote_cache.default_ttl 192 192 193 193 - let () = 194 194 - Alcotest.run "Remote_cache" 195 195 - [ 196 196 - ( "basic", 197 197 - [ 198 198 - Alcotest.test_case "empty cache" `Quick test_empty_cache; 199 199 - Alcotest.test_case "set and get" `Quick test_set_get; 200 200 - Alcotest.test_case "different branches" `Quick test_different_branches; 201 201 - Alcotest.test_case "different urls" `Quick test_different_urls; 202 202 - Alcotest.test_case "update existing" `Quick test_update_existing; 203 203 - Alcotest.test_case "clear" `Quick test_clear; 204 204 - ] ); 205 205 - ( "expiration", 206 206 - [ 207 207 - Alcotest.test_case "basic expiration" `Quick test_expiration; 208 208 - Alcotest.test_case "boundary" `Quick test_expiration_boundary; 209 209 - Alcotest.test_case "refresh extends ttl" `Quick 210 210 - test_refresh_extends_ttl; 211 211 - Alcotest.test_case "default ttl" `Quick test_default_ttl; 212 212 - ] ); 213 213 - ( "serialization", 214 214 - [ 215 215 - Alcotest.test_case "roundtrip" `Quick test_serialization; 216 216 - Alcotest.test_case "excludes expired" `Quick 217 217 - test_serialization_excludes_expired; 218 218 - ] ); 219 219 - ( "performance", 220 220 - [ Alcotest.test_case "1000 entries" `Quick test_many_entries ] ); 221 221 - ] 193 193 + let suite = 194 194 + [ 195 195 + ( "Remote_cache: basic", 196 196 + [ 197 197 + Alcotest.test_case "empty cache" `Quick test_empty_cache; 198 198 + Alcotest.test_case "set and get" `Quick test_set_get; 199 199 + Alcotest.test_case "different branches" `Quick test_different_branches; 200 200 + Alcotest.test_case "different urls" `Quick test_different_urls; 201 201 + Alcotest.test_case "update existing" `Quick test_update_existing; 202 202 + Alcotest.test_case "clear" `Quick test_clear; 203 203 + ] ); 204 204 + ( "Remote_cache: expiration", 205 205 + [ 206 206 + Alcotest.test_case "basic expiration" `Quick test_expiration; 207 207 + Alcotest.test_case "boundary" `Quick test_expiration_boundary; 208 208 + Alcotest.test_case "refresh extends ttl" `Quick test_refresh_extends_ttl; 209 209 + Alcotest.test_case "default ttl" `Quick test_default_ttl; 210 210 + ] ); 211 211 + ( "Remote_cache: serialization", 212 212 + [ 213 213 + Alcotest.test_case "roundtrip" `Quick test_serialization; 214 214 + Alcotest.test_case "excludes expired" `Quick 215 215 + test_serialization_excludes_expired; 216 216 + ] ); 217 217 + ( "Remote_cache: performance", 218 218 + [ Alcotest.test_case "1000 entries" `Quick test_many_entries ] ); 219 219 + ]

+251

test/test_status.ml

reviewed

··· 1 1 + (* Tests for Status module *) 2 2 + 3 3 + module Status = Monopam.Status 4 4 + module Package = Monopam.Package 5 5 + 6 6 + (* Helper to create a test package *) 7 7 + let make_package name = 8 8 + let dev_repo = Uri.of_string ("https://github.com/test/" ^ name ^ ".git") in 9 9 + Package.create ~name ~version:"dev" ~dev_repo () 10 10 + 11 11 + (* Helper to create a status with given parameters *) 12 12 + let make_status ?(checkout = Status.Missing) ?(subtree = Status.Not_added) 13 13 + ?(subtree_sync = Status.Unknown) name = 14 14 + let package = make_package name in 15 15 + { Status.package; checkout; subtree; subtree_sync } 16 16 + 17 17 + (* Test predicates *) 18 18 + 19 19 + let test_is_checkout_clean_missing () = 20 20 + let s = make_status ~checkout:Status.Missing "pkg" in 21 21 + Alcotest.(check bool) 22 22 + "missing is not clean" false 23 23 + (Status.is_checkout_clean s) 24 24 + 25 25 + let test_is_checkout_clean_not_repo () = 26 26 + let s = make_status ~checkout:Status.Not_a_repo "pkg" in 27 27 + Alcotest.(check bool) 28 28 + "not repo is not clean" false 29 29 + (Status.is_checkout_clean s) 30 30 + 31 31 + let test_is_checkout_clean_dirty () = 32 32 + let s = make_status ~checkout:Status.Dirty "pkg" in 33 33 + Alcotest.(check bool) "dirty is not clean" false (Status.is_checkout_clean s) 34 34 + 35 35 + let test_is_checkout_clean_yes () = 36 36 + let s = 37 37 + make_status ~checkout:(Status.Clean { ahead = 0; behind = 0 }) "pkg" 38 38 + in 39 39 + Alcotest.(check bool) "clean is clean" true (Status.is_checkout_clean s) 40 40 + 41 41 + let test_is_checkout_clean_with_ahead () = 42 42 + let s = 43 43 + make_status ~checkout:(Status.Clean { ahead = 5; behind = 0 }) "pkg" 44 44 + in 45 45 + Alcotest.(check bool) 46 46 + "clean with ahead is clean" true 47 47 + (Status.is_checkout_clean s) 48 48 + 49 49 + (* Test needs_pull *) 50 50 + 51 51 + let test_needs_pull_behind () = 52 52 + let s = 53 53 + make_status ~checkout:(Status.Clean { ahead = 0; behind = 3 }) "pkg" 54 54 + in 55 55 + Alcotest.(check bool) "behind needs pull" true (Status.needs_pull s) 56 56 + 57 57 + let test_needs_pull_not_behind () = 58 58 + let s = 59 59 + make_status ~checkout:(Status.Clean { ahead = 2; behind = 0 }) "pkg" 60 60 + in 61 61 + Alcotest.(check bool) "not behind no pull" false (Status.needs_pull s) 62 62 + 63 63 + let test_needs_pull_dirty () = 64 64 + let s = make_status ~checkout:Status.Dirty "pkg" in 65 65 + Alcotest.(check bool) "dirty no pull" false (Status.needs_pull s) 66 66 + 67 67 + (* Test needs_push *) 68 68 + 69 69 + let test_needs_push_ahead () = 70 70 + let s = 71 71 + make_status ~checkout:(Status.Clean { ahead = 2; behind = 0 }) "pkg" 72 72 + in 73 73 + Alcotest.(check bool) "ahead needs push" true (Status.needs_push s) 74 74 + 75 75 + let test_needs_push_not_ahead () = 76 76 + let s = 77 77 + make_status ~checkout:(Status.Clean { ahead = 0; behind = 3 }) "pkg" 78 78 + in 79 79 + Alcotest.(check bool) "not ahead no push" false (Status.needs_push s) 80 80 + 81 81 + (* Test needs_local_sync *) 82 82 + 83 83 + let test_needs_local_sync_in_sync () = 84 84 + let s = make_status ~subtree_sync:Status.In_sync "pkg" in 85 85 + Alcotest.(check bool) "in sync no action" false (Status.needs_local_sync s) 86 86 + 87 87 + let test_needs_local_sync_behind () = 88 88 + let s = make_status ~subtree_sync:(Status.Subtree_behind 3) "pkg" in 89 89 + Alcotest.(check bool) 90 90 + "subtree behind needs sync" true 91 91 + (Status.needs_local_sync s) 92 92 + 93 93 + let test_needs_local_sync_ahead () = 94 94 + let s = make_status ~subtree_sync:(Status.Subtree_ahead 2) "pkg" in 95 95 + Alcotest.(check bool) 96 96 + "subtree ahead needs sync" true 97 97 + (Status.needs_local_sync s) 98 98 + 99 99 + let test_needs_local_sync_differ () = 100 100 + let s = make_status ~subtree_sync:Status.Trees_differ "pkg" in 101 101 + Alcotest.(check bool) 102 102 + "trees differ needs sync" true 103 103 + (Status.needs_local_sync s) 104 104 + 105 105 + (* Test needs_remote_action *) 106 106 + 107 107 + let test_needs_remote_action_ahead () = 108 108 + let s = 109 109 + make_status ~checkout:(Status.Clean { ahead = 2; behind = 0 }) "pkg" 110 110 + in 111 111 + Alcotest.(check bool) "ahead needs remote" true (Status.needs_remote_action s) 112 112 + 113 113 + let test_needs_remote_action_behind () = 114 114 + let s = 115 115 + make_status ~checkout:(Status.Clean { ahead = 0; behind = 3 }) "pkg" 116 116 + in 117 117 + Alcotest.(check bool) 118 118 + "behind needs remote" true 119 119 + (Status.needs_remote_action s) 120 120 + 121 121 + let test_needs_remote_action_synced () = 122 122 + let s = 123 123 + make_status ~checkout:(Status.Clean { ahead = 0; behind = 0 }) "pkg" 124 124 + in 125 125 + Alcotest.(check bool) "synced no remote" false (Status.needs_remote_action s) 126 126 + 127 127 + (* Test is_fully_synced *) 128 128 + 129 129 + let test_is_fully_synced_yes () = 130 130 + let s = 131 131 + make_status 132 132 + ~checkout:(Status.Clean { ahead = 0; behind = 0 }) 133 133 + ~subtree:Status.Present ~subtree_sync:Status.In_sync "pkg" 134 134 + in 135 135 + Alcotest.(check bool) "all synced" true (Status.is_fully_synced s) 136 136 + 137 137 + let test_is_fully_synced_checkout_ahead () = 138 138 + let s = 139 139 + make_status 140 140 + ~checkout:(Status.Clean { ahead = 1; behind = 0 }) 141 141 + ~subtree:Status.Present ~subtree_sync:Status.In_sync "pkg" 142 142 + in 143 143 + Alcotest.(check bool) 144 144 + "checkout ahead not synced" false (Status.is_fully_synced s) 145 145 + 146 146 + let test_is_fully_synced_subtree_not_added () = 147 147 + let s = 148 148 + make_status 149 149 + ~checkout:(Status.Clean { ahead = 0; behind = 0 }) 150 150 + ~subtree:Status.Not_added ~subtree_sync:Status.Unknown "pkg" 151 151 + in 152 152 + Alcotest.(check bool) 153 153 + "subtree not added not synced" false (Status.is_fully_synced s) 154 154 + 155 155 + let test_is_fully_synced_trees_differ () = 156 156 + let s = 157 157 + make_status 158 158 + ~checkout:(Status.Clean { ahead = 0; behind = 0 }) 159 159 + ~subtree:Status.Present ~subtree_sync:Status.Trees_differ "pkg" 160 160 + in 161 161 + Alcotest.(check bool) 162 162 + "trees differ not synced" false (Status.is_fully_synced s) 163 163 + 164 164 + (* Test filter_actionable *) 165 165 + 166 166 + let test_filter_actionable_all_synced () = 167 167 + let synced = 168 168 + make_status 169 169 + ~checkout:(Status.Clean { ahead = 0; behind = 0 }) 170 170 + ~subtree:Status.Present ~subtree_sync:Status.In_sync "pkg" 171 171 + in 172 172 + let result = Status.filter_actionable [ synced ] in 173 173 + Alcotest.(check int) "no actionable" 0 (List.length result) 174 174 + 175 175 + let test_filter_actionable_mixed () = 176 176 + let synced = 177 177 + make_status 178 178 + ~checkout:(Status.Clean { ahead = 0; behind = 0 }) 179 179 + ~subtree:Status.Present ~subtree_sync:Status.In_sync "synced" 180 180 + in 181 181 + let needs_push = 182 182 + make_status 183 183 + ~checkout:(Status.Clean { ahead = 2; behind = 0 }) 184 184 + ~subtree:Status.Present ~subtree_sync:Status.In_sync "needs-push" 185 185 + in 186 186 + let needs_sync = 187 187 + make_status 188 188 + ~checkout:(Status.Clean { ahead = 0; behind = 0 }) 189 189 + ~subtree:Status.Present ~subtree_sync:(Status.Subtree_behind 1) 190 190 + "needs-sync" 191 191 + in 192 192 + let dirty = 193 193 + make_status ~checkout:Status.Dirty ~subtree:Status.Present 194 194 + ~subtree_sync:Status.Unknown "dirty" 195 195 + in 196 196 + let result = 197 197 + Status.filter_actionable [ synced; needs_push; needs_sync; dirty ] 198 198 + in 199 199 + Alcotest.(check int) "3 actionable" 3 (List.length result) 200 200 + 201 201 + let suite = 202 202 + [ 203 203 + ( "Status: is_checkout_clean", 204 204 + [ 205 205 + Alcotest.test_case "missing" `Quick test_is_checkout_clean_missing; 206 206 + Alcotest.test_case "not repo" `Quick test_is_checkout_clean_not_repo; 207 207 + Alcotest.test_case "dirty" `Quick test_is_checkout_clean_dirty; 208 208 + Alcotest.test_case "clean" `Quick test_is_checkout_clean_yes; 209 209 + Alcotest.test_case "clean with ahead" `Quick 210 210 + test_is_checkout_clean_with_ahead; 211 211 + ] ); 212 212 + ( "Status: needs_pull", 213 213 + [ 214 214 + Alcotest.test_case "behind" `Quick test_needs_pull_behind; 215 215 + Alcotest.test_case "not behind" `Quick test_needs_pull_not_behind; 216 216 + Alcotest.test_case "dirty" `Quick test_needs_pull_dirty; 217 217 + ] ); 218 218 + ( "Status: needs_push", 219 219 + [ 220 220 + Alcotest.test_case "ahead" `Quick test_needs_push_ahead; 221 221 + Alcotest.test_case "not ahead" `Quick test_needs_push_not_ahead; 222 222 + ] ); 223 223 + ( "Status: needs_local_sync", 224 224 + [ 225 225 + Alcotest.test_case "in sync" `Quick test_needs_local_sync_in_sync; 226 226 + Alcotest.test_case "behind" `Quick test_needs_local_sync_behind; 227 227 + Alcotest.test_case "ahead" `Quick test_needs_local_sync_ahead; 228 228 + Alcotest.test_case "differ" `Quick test_needs_local_sync_differ; 229 229 + ] ); 230 230 + ( "Status: needs_remote_action", 231 231 + [ 232 232 + Alcotest.test_case "ahead" `Quick test_needs_remote_action_ahead; 233 233 + Alcotest.test_case "behind" `Quick test_needs_remote_action_behind; 234 234 + Alcotest.test_case "synced" `Quick test_needs_remote_action_synced; 235 235 + ] ); 236 236 + ( "Status: is_fully_synced", 237 237 + [ 238 238 + Alcotest.test_case "all synced" `Quick test_is_fully_synced_yes; 239 239 + Alcotest.test_case "checkout ahead" `Quick 240 240 + test_is_fully_synced_checkout_ahead; 241 241 + Alcotest.test_case "subtree not added" `Quick 242 242 + test_is_fully_synced_subtree_not_added; 243 243 + Alcotest.test_case "trees differ" `Quick 244 244 + test_is_fully_synced_trees_differ; 245 245 + ] ); 246 246 + ( "Status: filter_actionable", 247 247 + [ 248 248 + Alcotest.test_case "all synced" `Quick test_filter_actionable_all_synced; 249 249 + Alcotest.test_case "mixed" `Quick test_filter_actionable_mixed; 250 250 + ] ); 251 251 + ]