+3 -1

lib/auto_resolve.ml

reviewed

··· 4 4 5 5 module Log = (val Logs.src_log src : Logs.LOG) 6 6 7 7 + let err_decode msg = Error (Fmt.str "decode failed: %s" msg) 8 8 + 7 9 type proposal = { 8 10 merged : string; 9 11 ours_summary : string; ··· 157 159 | Some text -> ( 158 160 match Jsont_bytesrw.decode_string proposal_jsont text with 159 161 | Ok p -> result := Ok p 160 160 - | Error e -> result := Error (Fmt.str "decode failed: %s" e)) 162 162 + | Error e -> result := err_decode e) 161 163 | None -> ()) 162 164 | Claude.Response.Error e -> 163 165 result := Error (Claude.Response.Error.message e)

+2 -2

lib/config.ml

reviewed

··· 261 261 with multiple monopam workspaces on one machine can [cd] into any of them 262 262 and have the tool pick up THAT workspace's config without needing to swap 263 263 [$HOME] or any global state. *) 264 264 - let find_workspace_config ~fs start = 264 264 + let workspace_config ~fs start = 265 265 let exists path = 266 266 let eio_path = Eio.Path.(fs / Fpath.to_string path) in 267 267 match Eio.Path.kind ~follow:true eio_path with ··· 296 296 XDG. If nothing is found we fall back to the XDG global config 297 297 so single-workspace users keep working as before. *) 298 298 let cwd = Fpath.v (Sys.getcwd ()) in 299 299 - match find_workspace_config ~fs cwd with 299 299 + match workspace_config ~fs cwd with 300 300 | Some path -> load_path ~fs path 301 301 | None -> load_path ~fs (file ()) 302 302

+4 -2

lib/dune_project.ml

reviewed

··· 21 21 22 22 module Sexp = Sexpt.Sexp 23 23 24 24 + let err_parse err = 25 25 + Error (Fmt.str "S-expression parse error: %s" (Sexp.Error.to_string err)) 26 26 + 24 27 (** Extract string from a Sexp.Atom, or None if it's a List *) 25 28 let atom_string = function Sexp.Atom s -> Some s | Sexp.List _ -> None 26 29 ··· 185 188 let parse content = 186 189 let content = preprocess_dune_strings content in 187 190 match Sexp.parse_string_many content with 188 188 - | Error err -> 189 189 - Error (Fmt.str "S-expression parse error: %s" (Sexp.Error.to_string err)) 191 191 + | Error err -> err_parse err 190 192 | Ok sexps -> ( 191 193 match string_field "name" sexps with 192 194 | None -> Error "dune-project missing (name ...) stanza"

+4 -2

lib/import.ml

reviewed

··· 17 17 let err_checkout_failed msg = 18 18 Error (Fmt.str "checkout failed after add: %s" msg) 19 19 20 20 + let err_no_history_at_path prefix = 21 21 + Error (Fmt.str "No history at path %S in the source repository" prefix) 22 22 + 20 23 (** {1 Types} *) 21 24 22 25 type source = ··· 202 205 let split_at_path git_repo ~prefix ~head = 203 206 match Git.Subtree.split git_repo ~prefix ~head () with 204 207 | Error (`Msg msg) -> Error msg 205 205 - | Ok None -> 206 206 - Error (Fmt.str "No history at path %S in the source repository" prefix) 208 208 + | Ok None -> err_no_history_at_path prefix 207 209 | Ok (Some split_head) -> Ok split_head 208 210 209 211 (** Import a single git URL as a subtree.

+5 -5

lib/lint.ml

reviewed

··· 201 201 let parse_sexps content = 202 202 match Sexp.parse_string_many content with Ok sexps -> sexps | Error _ -> [] 203 203 204 204 - let find_field name sexps = 204 204 + let field name sexps = 205 205 List.find_map 206 206 (function 207 207 | Sexp.List (Sexp.Atom n :: rest) when n = name -> Some rest | _ -> None) ··· 211 211 tools like menhir detected from [(menhir ...)] stanzas. *) 212 212 let extract_used_libs sexps = 213 213 let from_fields fields = 214 214 - match find_field "libraries" fields with 214 214 + match field "libraries" fields with 215 215 | None -> [] 216 216 | Some libs -> 217 217 List.filter_map ··· 237 237 | _ -> []) 238 238 sexps 239 239 240 240 - let rec find_dune_files ~fs dir = 240 240 + let rec dune_files_in ~fs dir = 241 241 let eio_path = Eio.Path.(fs / Fpath.to_string dir) in 242 242 let entries = try Eio.Path.read_dir eio_path with Eio.Io _ -> [] in 243 243 List.concat_map ··· 248 248 let child = Fpath.(dir / entry) in 249 249 let eio_child = Eio.Path.(fs / Fpath.to_string child) in 250 250 match Eio.Path.kind ~follow:false eio_child with 251 251 - | `Directory -> find_dune_files ~fs child 251 251 + | `Directory -> dune_files_in ~fs child 252 252 | `Regular_file when entry = "dune" -> [ child ] 253 253 | _ -> [] 254 254 | exception Eio.Io _ -> []) ··· 257 257 (** Collect all packages referenced via [(libraries ...)] in any dune file in a 258 258 subtree. This covers executable and test deps not captured by META. *) 259 259 let dune_needed_packages ~fs ~index subtree_path = 260 260 - let dune_files = find_dune_files ~fs subtree_path in 260 260 + let dune_files = dune_files_in ~fs subtree_path in 261 261 List.concat_map 262 262 (fun df -> 263 263 match load_file fs df with

+9 -9

lib/push.ml

reviewed

··· 105 105 | `Directory when Git.Repository.is_repo ~fs checkout_dir -> false 106 106 | _ -> true 107 107 108 108 - type push_result = 108 108 + type result = 109 109 | Pushed (** Subtree was exported and pushed to checkout *) 110 110 | Skipped (** Nothing to push (up-to-date or not in monorepo) *) 111 111 | Clone_failed of string (** Remote repo doesn't exist or is unreachable *) ··· 432 432 | Error e -> Error (name, push_url, Ctx.Git_error e)) 433 433 pushed_repos 434 434 435 435 - let log_push_results push_results = 435 435 + let log_results results = 436 436 let successes, failures = 437 437 List.partition_map 438 438 (function 439 439 | Ok (name, url) -> Left (name, url) 440 440 | Error (name, url, _) -> Right (name, url)) 441 441 - push_results 441 441 + results 442 442 in 443 443 if successes <> [] || failures <> [] then begin 444 444 let rows = ··· 471 471 in 472 472 Log.app (fun m -> m "%s" (Tty.Table.to_string table)) 473 473 end; 474 474 - match List.find_opt Result.is_error push_results with 474 474 + match List.find_opt Result.is_error results with 475 475 | Some (Error (_, _, e)) -> Error e 476 476 | _ -> Ok () 477 477 ··· 618 618 Without this step, the inner mono's git history never receives the outer's 619 619 edits and a downstream developer pulling from open-mono.git would not see 620 620 them. *) 621 621 - let push_mono_outer_subtree ~sw ~proc ~fs_t ~monorepo ~checkouts_root ~git_repo 621 621 + let mono_outer_subtree ~sw ~proc ~fs_t ~monorepo ~checkouts_root ~git_repo 622 622 ~clean ~force mono_name mono_entry = 623 623 match mono_entry with 624 624 | None -> ··· 673 673 in 674 674 List.iter 675 675 (fun (mono_name, entry) -> 676 676 - push_mono_outer_subtree ~sw ~proc ~fs_t ~monorepo ~checkouts_root 677 677 - ~git_repo ~clean ~force mono_name entry) 676 676 + mono_outer_subtree ~sw ~proc ~fs_t ~monorepo ~checkouts_root ~git_repo 677 677 + ~clean ~force mono_name entry) 678 678 nested; 679 679 inner_errors 680 680 end ··· 764 764 Tty.Progress.finish progress; 765 765 Error e 766 766 | Ok (pushed_repos, missing) -> ( 767 767 - let push_results = 767 767 + let results = 768 768 if upstream && pushed_repos <> [] then 769 769 to_upstream ~sw ~proc ~fs:fs_t ~config ~sources ~force ~progress 770 770 pushed_repos ··· 781 781 in 782 782 Tty.Progress.finish ~message:"exported" progress; 783 783 log_missing_repos ~all_pkgs missing; 784 784 - match log_push_results push_results with 784 784 + match log_results results with 785 785 | Error e -> Error e 786 786 | Ok () -> 787 787 let ws_errors =

+2 -2

lib/push.mli

reviewed

··· 12 12 ?force:bool -> 13 13 unit -> 14 14 (unit, Ctx.error) result 15 15 - (** [run ~sw ~proc ~fs ~config ()] exports changes via subtree split and pushes 16 16 - to local checkouts and optionally to remote upstreams. *) 15 15 + (** [run ~sw ~clock ~proc ~fs ~config ()] exports changes via subtree split and 16 16 + pushes to local checkouts and optionally to remote upstreams. *)

+20

lib/quality.mli

reviewed

··· 31 31 } 32 32 33 33 val subtree_hash : Git.Repository.t -> string -> string 34 34 + (** [subtree_hash repo prefix] returns the hex tree hash of [prefix] at HEAD, or 35 35 + the empty string if the path is not present. *) 36 36 + 34 37 val check : repo:Git.Repository.t -> ?tools:bool -> string -> string -> result 38 38 + (** [check ~repo ?tools pkg_dir name] returns the policy/present/missing 39 39 + breakdown for the package at [pkg_dir]. With [~tools:true] runs merlint, 40 40 + prune, and dupfind in addition to the static checks. *) 41 41 + 35 42 val check_all : repo:Git.Repository.t -> ?tools:bool -> string -> result list 43 43 + (** [check_all ~repo ?tools root] runs {!check} on every package directory under 44 44 + [root] (any subdirectory containing a [dune-project]). *) 45 45 + 36 46 val pp_entry : result Fmt.t 47 47 + (** [pp_entry] prints one line summarising a {!result}: package name, short tree 48 48 + hash, and per-feature ✓/✗/· markers. *) 49 49 + 37 50 val pp_summary : result list Fmt.t 51 51 + (** [pp_summary] prints aggregate counts across a list of {!result}s: totals 52 52 + plus per-feature counts. *) 53 53 + 38 54 val has_failures : result list -> bool 55 55 + (** [has_failures rs] is [true] if any result in [rs] has a non-empty [missing] 56 56 + field. *) 57 57 + 39 58 val query_missing : string -> result list -> result list 59 59 + (** [query_missing feature rs] returns the subset of [rs] missing [feature]. *)

+5 -6

test/cli/demo.ml

reviewed

··· 38 38 ~style:`Plain ~total:5 "Push" 39 39 in 40 40 for i = 1 to 5 do 41 41 - Tty.Progress.update bar ~phase:"Export" ~msg:(Printf.sprintf "repo-%d" i); 42 42 - if mode = "broken" then 43 43 - Format.fprintf Format.str_formatter " ✓ repo-%d\n%!" i 41 41 + Tty.Progress.update bar ~phase:"Export" ~msg:(Fmt.str "repo-%d" i); 42 42 + if mode = "broken" then Fmt.pf Format.str_formatter " ✓ repo-%d@\n@?" i 44 43 else if mode = "fixed" then 45 44 Tty.Progress.suspend (fun () -> 46 46 - Format.fprintf Format.str_formatter " * repo-%d\n%!" i) 45 45 + Fmt.pf Format.str_formatter " * repo-%d@\n@?" i) 47 46 done; 48 47 Tty.Progress.finish bar; 49 48 let raw = Format.flush_str_formatter () in 50 49 let lines = visible_lines (strip_ansi raw) in 51 51 - Printf.printf "%d visible lines:\n" (List.length lines); 52 52 - List.iter (fun l -> Printf.printf " %s\n" l) lines 50 50 + Fmt.pr "%d visible lines:@." (List.length lines); 51 51 + List.iter (fun l -> Fmt.pr " %s@." l) lines

+1 -1

test/cli/dune

reviewed

··· 1 1 (executable 2 2 (name demo) 3 3 - (libraries tty unix)) 3 3 + (libraries fmt tty unix)) 4 4 5 5 (cram 6 6 (deps demo.exe))

+5 -5

test/test_ctx.ml

reviewed

··· 100 100 scripts can tell user errors from network issues, conflicts, and 101 101 external-service failures. *) 102 102 103 103 - let make_cmd_failed ?(stderr = "") ?(stdout = "") ?(exit = 128) cmd = 103 103 + let cmd_failed ?(stderr = "") ?(stdout = "") ?(exit = 128) cmd = 104 104 Ctx.Git_error 105 105 (Monopam.Git_cli.Command_failed 106 106 (cmd, Monopam.Git_cli.{ exit_code = exit; stdout; stderr })) ··· 136 136 Alcotest.(check int) 137 137 "git push unreachable" 3 138 138 (Ctx.exit_code 139 139 - (make_cmd_failed "git push origin main" 139 139 + (cmd_failed "git push origin main" 140 140 ~stderr:"fatal: Could not resolve host: github.com")); 141 141 Alcotest.(check int) 142 142 "git fetch timeout" 3 143 143 (Ctx.exit_code 144 144 - (make_cmd_failed "git fetch origin" 144 144 + (cmd_failed "git fetch origin" 145 145 ~stderr:"fatal: unable to access 'https://...': Connection refused")) 146 146 147 147 let test_exit_conflict () = 148 148 Alcotest.(check int) 149 149 "non-fast-forward" 4 150 150 (Ctx.exit_code 151 151 - (make_cmd_failed "git push origin main" 151 151 + (cmd_failed "git push origin main" 152 152 ~stderr:"! [rejected] main -> main (non-fast-forward)")); 153 153 Alcotest.(check int) 154 154 "fetch first" 4 155 155 (Ctx.exit_code 156 156 - (make_cmd_failed "git push origin main" 156 156 + (cmd_failed "git push origin main" 157 157 ~stderr:"error: hint: Updates were rejected... fetch first")) 158 158 159 159 let test_exit_external () =