Monorepo management for opam overlays
toml, monopam: follow loc Context move + plain Json.to_string
- toml error_to_loc: Loc.Error moved Context to top-level Loc.Context;
adjust to [Error.msg ~ctx:Context.empty ~meta:Meta.none].
- monopam: [open Jsont] -> [open Json.Codec] for codec definitions.
- monopam: Json.to_string returns plain string now, drop result patterns.
- monopam tests: the string-typed errors no longer need [Json.Error.to_string]
wraps at call sites.
+254
-261
+3
-1
bin/cmd_remove.ml
+3
-1
bin/cmd_remove.ml
···
75
75
sources_path sources'
76
76
with
77
77
| Ok () -> Fmt.pr "Updated sources.toml@."
78
-
| Error e -> Fmt.epr "Warning: failed to update sources.toml: %s@." e)
78
+
| Error e ->
79
+
Fmt.epr "Warning: failed to update sources.toml: %s@."
80
+
e)
79
81
| Error _ -> ()
80
82
81
83
let commit_removal ~proc ~cwd dir =
+1
-1
dune-project
+1
-1
dune-project
+13
-12
lib/auto_resolve.ml
+13
-12
lib/auto_resolve.ml
···
4
4
5
5
module Log = (val Logs.src_log src : Logs.LOG)
6
6
7
-
let err_decode msg = Error (Fmt.str "decode failed: %s" msg)
7
+
let err_decode e =
8
+
Error (Fmt.str "decode failed: %s" (Json.Error.to_string e))
8
9
9
10
type proposal = {
10
11
merged : string;
···
87
88
88
89
(** {1 Claude strategy} *)
89
90
90
-
let proposal_jsont : proposal Jsont.t =
91
-
let open Jsont in
92
-
Object.(
93
-
map (fun merged ours_summary theirs_summary rationale ->
94
-
{ merged; ours_summary; theirs_summary; rationale })
95
-
|> mem "merged" string ~enc:(fun p -> p.merged)
96
-
|> mem "ours_summary" string ~enc:(fun p -> p.ours_summary)
97
-
|> mem "theirs_summary" string ~enc:(fun p -> p.theirs_summary)
98
-
|> mem "rationale" string ~enc:(fun p -> p.rationale)
99
-
|> finish)
91
+
let proposal_json : proposal Json.codec =
92
+
let open Json.Codec in
93
+
Object.map ~kind:"Proposal"
94
+
(fun merged ours_summary theirs_summary rationale ->
95
+
{ merged; ours_summary; theirs_summary; rationale })
96
+
|> Object.mem "merged" string ~enc:(fun p -> p.merged)
97
+
|> Object.mem "ours_summary" string ~enc:(fun p -> p.ours_summary)
98
+
|> Object.mem "theirs_summary" string ~enc:(fun p -> p.theirs_summary)
99
+
|> Object.mem "rationale" string ~enc:(fun p -> p.rationale)
100
+
|> Object.finish
100
101
101
102
let prompt_for path ~chunks =
102
103
let buf = Buffer.create 512 in
···
157
158
| Claude.Response.Complete c -> (
158
159
match Claude.Response.Complete.result_text c with
159
160
| Some text -> (
160
-
match Jsont_bytesrw.decode_string proposal_jsont text with
161
+
match Json.of_string proposal_json text with
161
162
| Ok p -> result := Ok p
162
163
| Error e -> result := err_decode e)
163
164
| None -> ())
+86
-101
lib/changes.ml
+86
-101
lib/changes.ml
···
25
25
26
26
(** {1 Error Helpers} *)
27
27
28
-
let err_parse name e = Error (Fmt.str "Failed to parse %s: %s" name e)
29
-
let err_encode name e = Error (Fmt.str "Failed to encode %s: %s" name e)
30
-
let err_claude_parse e = Error (Fmt.str "Failed to parse Claude response: %s" e)
31
-
let err_decode e = Error (Fmt.str "Failed to decode response: %s" e)
28
+
let err_parse name e =
29
+
Error (Fmt.str "Failed to parse %s: %s" name (Json.Error.to_string e))
30
+
31
+
let err_claude_parse e =
32
+
Error (Fmt.str "Failed to parse Claude response: %s" (Json.Error.to_string e))
33
+
34
+
let err_decode e =
35
+
Error (Fmt.str "Failed to decode response: %s" (Json.Error.to_string e))
32
36
33
37
type commit_range = { from_hash : string; to_hash : string; count : int }
34
38
···
61
65
62
66
let commit_range_jsont =
63
67
let make from_hash to_hash count = { from_hash; to_hash; count } in
64
-
Jsont.Object.map ~kind:"commit_range" make
65
-
|> Jsont.Object.mem "from" Jsont.string ~enc:(fun r -> r.from_hash)
66
-
|> Jsont.Object.mem "to" Jsont.string ~enc:(fun r -> r.to_hash)
67
-
|> Jsont.Object.mem "count" Jsont.int ~enc:(fun r -> r.count)
68
-
|> Jsont.Object.finish
68
+
Json.Codec.Object.map ~kind:"commit_range" make
69
+
|> Json.Codec.Object.mem "from" Json.Codec.string ~enc:(fun r -> r.from_hash)
70
+
|> Json.Codec.Object.mem "to" Json.Codec.string ~enc:(fun r -> r.to_hash)
71
+
|> Json.Codec.Object.mem "count" Json.Codec.int ~enc:(fun r -> r.count)
72
+
|> Json.Codec.Object.finish
69
73
70
-
let weekly_entry_jsont : weekly_entry Jsont.t =
74
+
let weekly_entry_jsont : weekly_entry Json.codec =
71
75
let make week_start week_end summary changes commit_range : weekly_entry =
72
76
{ week_start; week_end; summary; changes; commit_range }
73
77
in
74
-
Jsont.Object.map ~kind:"weekly_entry" make
75
-
|> Jsont.Object.mem "week_start" Jsont.string ~enc:(fun (e : weekly_entry) ->
76
-
e.week_start)
77
-
|> Jsont.Object.mem "week_end" Jsont.string ~enc:(fun (e : weekly_entry) ->
78
-
e.week_end)
79
-
|> Jsont.Object.mem "summary" Jsont.string ~enc:(fun (e : weekly_entry) ->
80
-
e.summary)
81
-
|> Jsont.Object.mem "changes" (Jsont.list Jsont.string)
78
+
Json.Codec.Object.map ~kind:"weekly_entry" make
79
+
|> Json.Codec.Object.mem "week_start" Json.Codec.string
80
+
~enc:(fun (e : weekly_entry) -> e.week_start)
81
+
|> Json.Codec.Object.mem "week_end" Json.Codec.string
82
+
~enc:(fun (e : weekly_entry) -> e.week_end)
83
+
|> Json.Codec.Object.mem "summary" Json.Codec.string
84
+
~enc:(fun (e : weekly_entry) -> e.summary)
85
+
|> Json.Codec.Object.mem "changes" (Json.Codec.list Json.Codec.string)
82
86
~enc:(fun (e : weekly_entry) -> e.changes)
83
-
|> Jsont.Object.mem "commit_range" commit_range_jsont
87
+
|> Json.Codec.Object.mem "commit_range" commit_range_jsont
84
88
~enc:(fun (e : weekly_entry) -> e.commit_range)
85
-
|> Jsont.Object.finish
89
+
|> Json.Codec.Object.finish
86
90
87
-
let file_jsont : file Jsont.t =
91
+
let file_jsont : file Json.codec =
88
92
let make repository entries : file = { repository; entries } in
89
-
Jsont.Object.map ~kind:"changes_file" make
90
-
|> Jsont.Object.mem "repository" Jsont.string ~enc:(fun (f : file) ->
91
-
f.repository)
92
-
|> Jsont.Object.mem "entries" (Jsont.list weekly_entry_jsont)
93
+
Json.Codec.Object.map ~kind:"changes_file" make
94
+
|> Json.Codec.Object.mem "repository" Json.Codec.string
95
+
~enc:(fun (f : file) -> f.repository)
96
+
|> Json.Codec.Object.mem "entries" (Json.Codec.list weekly_entry_jsont)
93
97
~enc:(fun (f : file) -> f.entries)
94
-
|> Jsont.Object.finish
98
+
|> Json.Codec.Object.finish
95
99
96
100
let ptime_jsont =
97
101
let enc t = Ptime.to_rfc3339 t ~tz_offset_s:0 in
···
100
104
| Ok (t, _, _) -> t
101
105
| Error _ -> failwith ("Invalid timestamp: " ^ s)
102
106
in
103
-
Jsont.map ~dec ~enc Jsont.string
107
+
Json.Codec.map ~dec ~enc Json.Codec.string
104
108
105
-
let daily_entry_jsont : daily_entry Jsont.t =
109
+
let daily_entry_jsont : daily_entry Json.codec =
106
110
let make date hour timestamp summary changes commit_range contributors
107
111
repo_url : daily_entry =
108
112
{
···
119
123
(* Default hour and timestamp for backwards compat when reading old files *)
120
124
let default_hour = 0 in
121
125
let default_timestamp = Ptime.epoch in
122
-
Jsont.Object.map ~kind:"daily_entry" make
123
-
|> Jsont.Object.mem "date" Jsont.string ~enc:(fun (e : daily_entry) -> e.date)
124
-
|> Jsont.Object.mem "hour" Jsont.int ~dec_absent:default_hour
126
+
Json.Codec.Object.map ~kind:"daily_entry" make
127
+
|> Json.Codec.Object.mem "date" Json.Codec.string
128
+
~enc:(fun (e : daily_entry) -> e.date)
129
+
|> Json.Codec.Object.mem "hour" Json.Codec.int ~dec_absent:default_hour
125
130
~enc:(fun (e : daily_entry) -> e.hour)
126
-
|> Jsont.Object.mem "timestamp" ptime_jsont ~dec_absent:default_timestamp
131
+
|> Json.Codec.Object.mem "timestamp" ptime_jsont ~dec_absent:default_timestamp
127
132
~enc:(fun (e : daily_entry) -> e.timestamp)
128
-
|> Jsont.Object.mem "summary" Jsont.string ~enc:(fun (e : daily_entry) ->
129
-
e.summary)
130
-
|> Jsont.Object.mem "changes" (Jsont.list Jsont.string)
133
+
|> Json.Codec.Object.mem "summary" Json.Codec.string
134
+
~enc:(fun (e : daily_entry) -> e.summary)
135
+
|> Json.Codec.Object.mem "changes" (Json.Codec.list Json.Codec.string)
131
136
~enc:(fun (e : daily_entry) -> e.changes)
132
-
|> Jsont.Object.mem "commit_range" commit_range_jsont
137
+
|> Json.Codec.Object.mem "commit_range" commit_range_jsont
133
138
~enc:(fun (e : daily_entry) -> e.commit_range)
134
-
|> Jsont.Object.mem "contributors" (Jsont.list Jsont.string) ~dec_absent:[]
135
-
~enc:(fun (e : daily_entry) -> e.contributors)
136
-
|> Jsont.Object.mem "repo_url" (Jsont.option Jsont.string) ~dec_absent:None
137
-
~enc:(fun (e : daily_entry) -> e.repo_url)
138
-
|> Jsont.Object.finish
139
+
|> Json.Codec.Object.mem "contributors" (Json.Codec.list Json.Codec.string)
140
+
~dec_absent:[] ~enc:(fun (e : daily_entry) -> e.contributors)
141
+
|> Json.Codec.Object.mem "repo_url" (Json.Codec.option Json.Codec.string)
142
+
~dec_absent:None ~enc:(fun (e : daily_entry) -> e.repo_url)
143
+
|> Json.Codec.Object.finish
139
144
140
-
let daily_file_jsont : daily_file Jsont.t =
145
+
let daily_file_jsont : daily_file Json.codec =
141
146
let make repository entries : daily_file = { repository; entries } in
142
-
Jsont.Object.map ~kind:"daily_changes_file" make
143
-
|> Jsont.Object.mem "repository" Jsont.string ~enc:(fun (f : daily_file) ->
144
-
f.repository)
145
-
|> Jsont.Object.mem "entries" (Jsont.list daily_entry_jsont)
147
+
Json.Codec.Object.map ~kind:"daily_changes_file" make
148
+
|> Json.Codec.Object.mem "repository" Json.Codec.string
149
+
~enc:(fun (f : daily_file) -> f.repository)
150
+
|> Json.Codec.Object.mem "entries" (Json.Codec.list daily_entry_jsont)
146
151
~enc:(fun (f : daily_file) -> f.entries)
147
-
|> Jsont.Object.finish
152
+
|> Json.Codec.Object.finish
148
153
149
154
(* File I/O *)
150
155
···
165
170
match Eio.Path.kind ~follow:true file_path with
166
171
| `Regular_file -> (
167
172
let content = Eio.Path.load file_path in
168
-
match Jsont_bytesrw.decode_string file_jsont content with
173
+
match Json.of_string file_jsont content with
169
174
| Ok cf -> Ok cf
170
175
| Error e -> err_parse (repo_name ^ ".json") e)
171
176
| _ -> Ok { repository = repo_name; entries = [] }
···
178
183
Eio.Path.(
179
184
fs / Fpath.to_string monorepo / ".changes" / (cf.repository ^ ".json"))
180
185
in
181
-
match Jsont_bytesrw.encode_string ~format:Jsont.Indent file_jsont cf with
182
-
| Ok content ->
183
-
Eio.Path.save ~create:(`Or_truncate 0o644) file_path content;
184
-
Ok ()
185
-
| Error e -> err_encode (cf.repository ^ ".json") e
186
+
let content = Json.to_string ~format:Json.Indent file_jsont cf in
187
+
Eio.Path.save ~create:(`Or_truncate 0o644) file_path content;
188
+
Ok ()
186
189
187
190
(* Filename for daily changes: <repo>-<YYYY-MM-DD>.json *)
188
191
let daily_filename repo_name date = repo_name ^ "-" ^ date ^ ".json"
···
207
210
match Eio.Path.kind ~follow:true file_path with
208
211
| `Regular_file -> (
209
212
let content = Eio.Path.load file_path in
210
-
match Jsont_bytesrw.decode_string daily_file_jsont content with
213
+
match Json.of_string daily_file_jsont content with
211
214
| Ok cf -> Ok cf
212
215
| Error e -> err_parse filename e)
213
216
| _ -> Ok { repository = repo_name; entries = [] }
···
220
223
let file_path =
221
224
Eio.Path.(fs / Fpath.to_string monorepo / ".changes" / filename)
222
225
in
223
-
match
224
-
Jsont_bytesrw.encode_string ~format:Jsont.Indent daily_file_jsont cf
225
-
with
226
-
| Ok content ->
227
-
Eio.Path.save ~create:(`Or_truncate 0o644) file_path content;
228
-
Ok ()
229
-
| Error e -> err_encode filename e
226
+
let content = Json.to_string ~format:Json.Indent daily_file_jsont cf in
227
+
Eio.Path.save ~create:(`Or_truncate 0o644) file_path content;
228
+
Ok ()
230
229
231
230
(* Markdown generation *)
232
231
···
529
528
530
529
let claude_response_jsont =
531
530
let make summary changes = { summary; changes } in
532
-
Jsont.Object.map ~kind:"claude_response" make
533
-
|> Jsont.Object.mem "summary" Jsont.string ~enc:(fun r -> r.summary)
534
-
|> Jsont.Object.mem "changes" (Jsont.list Jsont.string) ~enc:(fun r ->
535
-
r.changes)
536
-
|> Jsont.Object.finish
531
+
Json.Codec.Object.map ~kind:"claude_response" make
532
+
|> Json.Codec.Object.mem "summary" Json.Codec.string ~enc:(fun r -> r.summary)
533
+
|> Json.Codec.Object.mem "changes" (Json.Codec.list Json.Codec.string)
534
+
~enc:(fun r -> r.changes)
535
+
|> Json.Codec.Object.finish
537
536
538
537
let parse_claude_response text =
539
538
let text = String.trim text in
540
539
(* Legacy support for NO_CHANGES response *)
541
540
if text = "NO_CHANGES" then Ok None
542
541
else
543
-
match Jsont_bytesrw.decode_string claude_response_jsont text with
542
+
match Json.of_string claude_response_jsont text with
544
543
| Ok r ->
545
544
(* Treat empty summary and changes as no changes *)
546
545
if r.summary = "" && r.changes = [] then Ok None else Ok (Some r)
···
549
548
(* Main analysis function *)
550
549
551
550
let changelog_output_schema =
552
-
let open Jsont in
553
-
Object
554
-
( [
555
-
(("type", Meta.none), String ("object", Meta.none));
556
-
( ("properties", Meta.none),
557
-
Object
558
-
( [
559
-
( ("summary", Meta.none),
560
-
Object
561
-
( [ (("type", Meta.none), String ("string", Meta.none)) ],
562
-
Meta.none ) );
563
-
( ("changes", Meta.none),
564
-
Object
565
-
( [
566
-
(("type", Meta.none), String ("array", Meta.none));
567
-
( ("items", Meta.none),
568
-
Object
569
-
( [
570
-
( ("type", Meta.none),
571
-
String ("string", Meta.none) );
572
-
],
573
-
Meta.none ) );
574
-
],
575
-
Meta.none ) );
576
-
],
577
-
Meta.none ) );
578
-
( ("required", Meta.none),
579
-
Array
580
-
( [ String ("summary", Meta.none); String ("changes", Meta.none) ],
581
-
Meta.none ) );
582
-
],
583
-
Meta.none )
551
+
let typ t = Json.object' [ Json.mem (Json.name "type") (Json.string t) ] in
552
+
Json.object'
553
+
[
554
+
Json.mem (Json.name "type") (Json.string "object");
555
+
Json.mem (Json.name "properties")
556
+
(Json.object'
557
+
[
558
+
Json.mem (Json.name "summary") (typ "string");
559
+
Json.mem (Json.name "changes")
560
+
(Json.object'
561
+
[
562
+
Json.mem (Json.name "type") (Json.string "array");
563
+
Json.mem (Json.name "items") (typ "string");
564
+
]);
565
+
]);
566
+
Json.mem (Json.name "required")
567
+
(Json.list [ Json.string "summary"; Json.string "changes" ]);
568
+
]
584
569
585
570
let process_claude_responses responses =
586
571
let result = ref None in
···
589
574
| Claude.Response.Complete c -> (
590
575
match Claude.Response.Complete.structured_output c with
591
576
| Some json -> (
592
-
match Jsont.Json.decode claude_response_jsont json with
577
+
match Json.decode claude_response_jsont json with
593
578
| Ok r ->
594
579
if r.summary = "" && r.changes = [] then
595
580
result := Some (Ok None)
···
759
744
let path = Eio.Path.(changes_dir / filename) in
760
745
try
761
746
let content = Eio.Path.load path in
762
-
match Jsont_bytesrw.decode_string daily_file_jsont content with
747
+
match Json.of_string daily_file_jsont content with
763
748
| Ok dcf ->
764
749
List.filter_map
765
750
(fun (e : daily_entry) ->
+5
-5
lib/changes.mli
+5
-5
lib/changes.mli
···
62
62
63
63
(** {1 JSON Codecs} *)
64
64
65
-
val commit_range_jsont : commit_range Jsont.t
65
+
val commit_range_jsont : commit_range Json.codec
66
66
(** JSON codec for commit ranges. *)
67
67
68
-
val weekly_entry_jsont : weekly_entry Jsont.t
68
+
val weekly_entry_jsont : weekly_entry Json.codec
69
69
(** JSON codec for weekly entries. *)
70
70
71
-
val file_jsont : file Jsont.t
71
+
val file_jsont : file Json.codec
72
72
(** JSON codec for weekly changes files. *)
73
73
74
-
val daily_entry_jsont : daily_entry Jsont.t
74
+
val daily_entry_jsont : daily_entry Json.codec
75
75
(** JSON codec for daily entries. *)
76
76
77
-
val daily_file_jsont : daily_file Jsont.t
77
+
val daily_file_jsont : daily_file Json.codec
78
78
(** JSON codec for daily changes files. *)
79
79
80
80
(** {1 File I/O} *)
+39
-39
lib/changes_aggregated.ml
+39
-39
lib/changes_aggregated.ml
···
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
-
let err_encode filename e = Error (Fmt.str "Failed to encode %s: %s" filename e)
19
18
20
19
type change_type =
21
20
| Feature
···
70
69
(* JSON codecs *)
71
70
72
71
let change_type_jsont =
73
-
Jsont.enum ~kind:"change_type"
72
+
Json.Codec.enum ~kind:"change_type"
74
73
[
75
74
("feature", Feature);
76
75
("bugfix", Bugfix);
···
82
81
83
82
let commit_range_jsont =
84
83
let make from_hash to_hash count = { from_hash; to_hash; count } in
85
-
Jsont.Object.map ~kind:"commit_range" make
86
-
|> Jsont.Object.mem "from" Jsont.string ~enc:(fun r -> r.from_hash)
87
-
|> Jsont.Object.mem "to" Jsont.string ~enc:(fun r -> r.to_hash)
88
-
|> Jsont.Object.mem "count" Jsont.int ~enc:(fun r -> r.count)
89
-
|> Jsont.Object.finish
84
+
Json.Codec.Object.map ~kind:"commit_range" make
85
+
|> Json.Codec.Object.mem "from" Json.Codec.string ~enc:(fun r -> r.from_hash)
86
+
|> Json.Codec.Object.mem "to" Json.Codec.string ~enc:(fun r -> r.to_hash)
87
+
|> Json.Codec.Object.mem "count" Json.Codec.int ~enc:(fun r -> r.count)
88
+
|> Json.Codec.Object.finish
90
89
91
90
let ptime_jsont =
92
91
let enc t = Ptime.to_rfc3339 t ~tz_offset_s:0 in
···
95
94
| Ok (t, _, _) -> t
96
95
| Error _ -> failwith ("Invalid timestamp: " ^ s)
97
96
in
98
-
Jsont.map ~dec ~enc Jsont.string
97
+
Json.Codec.map ~dec ~enc Json.Codec.string
99
98
100
99
let entry_jsont =
101
100
let make repository hour timestamp summary changes commit_range contributors
···
115
114
(* Default hour and timestamp for backwards compat when reading old files *)
116
115
let default_hour = 0 in
117
116
let default_timestamp = Ptime.epoch in
118
-
Jsont.Object.map ~kind:"aggregated_entry" make
119
-
|> Jsont.Object.mem "repository" Jsont.string ~enc:(fun e -> e.repository)
120
-
|> Jsont.Object.mem "hour" Jsont.int ~dec_absent:default_hour ~enc:(fun e ->
121
-
e.hour)
122
-
|> Jsont.Object.mem "timestamp" ptime_jsont ~dec_absent:default_timestamp
117
+
Json.Codec.Object.map ~kind:"aggregated_entry" make
118
+
|> Json.Codec.Object.mem "repository" Json.Codec.string ~enc:(fun e ->
119
+
e.repository)
120
+
|> Json.Codec.Object.mem "hour" Json.Codec.int ~dec_absent:default_hour
121
+
~enc:(fun e -> e.hour)
122
+
|> Json.Codec.Object.mem "timestamp" ptime_jsont ~dec_absent:default_timestamp
123
123
~enc:(fun e -> e.timestamp)
124
-
|> Jsont.Object.mem "summary" Jsont.string ~enc:(fun e -> e.summary)
125
-
|> Jsont.Object.mem "changes" (Jsont.list Jsont.string) ~enc:(fun e ->
126
-
e.changes)
127
-
|> Jsont.Object.mem "commit_range" commit_range_jsont ~enc:(fun e ->
124
+
|> Json.Codec.Object.mem "summary" Json.Codec.string ~enc:(fun e -> e.summary)
125
+
|> Json.Codec.Object.mem "changes" (Json.Codec.list Json.Codec.string)
126
+
~enc:(fun e -> e.changes)
127
+
|> Json.Codec.Object.mem "commit_range" commit_range_jsont ~enc:(fun e ->
128
128
e.commit_range)
129
-
|> Jsont.Object.mem "contributors" (Jsont.list Jsont.string) ~dec_absent:[]
130
-
~enc:(fun e -> e.contributors)
131
-
|> Jsont.Object.mem "repo_url" (Jsont.option Jsont.string) ~dec_absent:None
132
-
~enc:(fun e -> e.repo_url)
133
-
|> Jsont.Object.mem "change_type" change_type_jsont ~dec_absent:Unknown
129
+
|> Json.Codec.Object.mem "contributors" (Json.Codec.list Json.Codec.string)
130
+
~dec_absent:[] ~enc:(fun e -> e.contributors)
131
+
|> Json.Codec.Object.mem "repo_url" (Json.Codec.option Json.Codec.string)
132
+
~dec_absent:None ~enc:(fun e -> e.repo_url)
133
+
|> Json.Codec.Object.mem "change_type" change_type_jsont ~dec_absent:Unknown
134
134
~enc:(fun e -> e.change_type)
135
-
|> Jsont.Object.finish
135
+
|> Json.Codec.Object.finish
136
136
137
137
let jsont =
138
138
let make date generated_at git_head entries authors =
139
139
{ date; generated_at; git_head; entries; authors }
140
140
in
141
-
Jsont.Object.map ~kind:"aggregated_changes" make
142
-
|> Jsont.Object.mem "date" Jsont.string ~enc:(fun t -> t.date)
143
-
|> Jsont.Object.mem "generated_at" ptime_jsont ~enc:(fun t -> t.generated_at)
144
-
|> Jsont.Object.mem "git_head" Jsont.string ~enc:(fun t -> t.git_head)
145
-
|> Jsont.Object.mem "entries" (Jsont.list entry_jsont) ~enc:(fun t ->
146
-
t.entries)
147
-
|> Jsont.Object.mem "authors" (Jsont.list Jsont.string) ~dec_absent:[]
148
-
~enc:(fun t -> t.authors)
149
-
|> Jsont.Object.finish
141
+
Json.Codec.Object.map ~kind:"aggregated_changes" make
142
+
|> Json.Codec.Object.mem "date" Json.Codec.string ~enc:(fun t -> t.date)
143
+
|> Json.Codec.Object.mem "generated_at" ptime_jsont ~enc:(fun t ->
144
+
t.generated_at)
145
+
|> Json.Codec.Object.mem "git_head" Json.Codec.string ~enc:(fun t ->
146
+
t.git_head)
147
+
|> Json.Codec.Object.mem "entries" (Json.Codec.list entry_jsont)
148
+
~enc:(fun t -> t.entries)
149
+
|> Json.Codec.Object.mem "authors" (Json.Codec.list Json.Codec.string)
150
+
~dec_absent:[] ~enc:(fun t -> t.authors)
151
+
|> Json.Codec.Object.finish
150
152
151
153
(* File I/O *)
152
154
···
171
173
match Eio.Path.kind ~follow:true file_path with
172
174
| `Regular_file -> (
173
175
let content = Eio.Path.load file_path in
174
-
match Jsont_bytesrw.decode_string jsont content with
176
+
match Json.of_string jsont content with
175
177
| Ok t -> Ok t
176
-
| Error e -> err_parse filename e)
178
+
| Error e -> err_parse filename (Json.Error.to_string e))
177
179
| _ -> err_not_found filename
178
180
| exception Eio.Io _ -> err_read filename
179
181
···
248
250
ensure_dir ~fs changes_dir;
249
251
let filename = filename_of_date t.date in
250
252
let file_path = Eio.Path.(fs / Fpath.to_string changes_dir / filename) in
251
-
match Jsont_bytesrw.encode_string ~format:Jsont.Indent jsont t with
252
-
| Ok content ->
253
-
Eio.Path.save ~create:(`Or_truncate 0o644) file_path content;
254
-
Ok ()
255
-
| Error e -> err_encode filename e
253
+
let content = Json.to_string ~format:Json.Indent jsont t in
254
+
Eio.Path.save ~create:(`Or_truncate 0o644) file_path content;
255
+
Ok ()
+2
-2
lib/changes_aggregated.mli
+2
-2
lib/changes_aggregated.mli
···
65
65
66
66
(** {1 JSON Codecs} *)
67
67
68
-
val jsont : t Jsont.t
68
+
val jsont : t Json.codec
69
69
(** JSON codec for the aggregated changes file. *)
70
70
71
-
val entry_jsont : entry Jsont.t
71
+
val entry_jsont : entry Json.codec
72
72
(** JSON codec for a single entry. *)
73
73
74
74
(** {1 File I/O} *)
+25
-25
lib/changes_daily.ml
+25
-25
lib/changes_daily.ml
···
43
43
44
44
let commit_range_jsont =
45
45
let make from_hash to_hash count = { from_hash; to_hash; count } in
46
-
Jsont.Object.map ~kind:"commit_range" make
47
-
|> Jsont.Object.mem "from" Jsont.string ~enc:(fun r -> r.from_hash)
48
-
|> Jsont.Object.mem "to" Jsont.string ~enc:(fun r -> r.to_hash)
49
-
|> Jsont.Object.mem "count" Jsont.int ~enc:(fun r -> r.count)
50
-
|> Jsont.Object.finish
46
+
Json.Codec.Object.map ~kind:"commit_range" make
47
+
|> Json.Codec.Object.mem "from" Json.Codec.string ~enc:(fun r -> r.from_hash)
48
+
|> Json.Codec.Object.mem "to" Json.Codec.string ~enc:(fun r -> r.to_hash)
49
+
|> Json.Codec.Object.mem "count" Json.Codec.int ~enc:(fun r -> r.count)
50
+
|> Json.Codec.Object.finish
51
51
52
52
let ptime_jsont =
53
53
let enc t = Ptime.to_rfc3339 t ~tz_offset_s:0 in
···
56
56
| Ok (t, _, _) -> t
57
57
| Error _ -> failwith ("Invalid timestamp: " ^ s)
58
58
in
59
-
Jsont.map ~dec ~enc Jsont.string
59
+
Json.Codec.map ~dec ~enc Json.Codec.string
60
60
61
61
(* Entry codec for the file format (without repository, added during load) *)
62
62
type file_entry = {
···
75
75
in
76
76
let default_hour = 0 in
77
77
let default_timestamp = Ptime.epoch in
78
-
Jsont.Object.map ~kind:"daily_entry" make
79
-
|> Jsont.Object.mem "hour" Jsont.int ~dec_absent:default_hour ~enc:(fun e ->
80
-
e.hour)
81
-
|> Jsont.Object.mem "timestamp" ptime_jsont ~dec_absent:default_timestamp
78
+
Json.Codec.Object.map ~kind:"daily_entry" make
79
+
|> Json.Codec.Object.mem "hour" Json.Codec.int ~dec_absent:default_hour
80
+
~enc:(fun e -> e.hour)
81
+
|> Json.Codec.Object.mem "timestamp" ptime_jsont ~dec_absent:default_timestamp
82
82
~enc:(fun e -> e.timestamp)
83
-
|> Jsont.Object.mem "summary" Jsont.string ~enc:(fun e -> e.summary)
84
-
|> Jsont.Object.mem "changes" (Jsont.list Jsont.string) ~enc:(fun e ->
85
-
e.changes)
86
-
|> Jsont.Object.mem "commit_range" commit_range_jsont ~enc:(fun e ->
83
+
|> Json.Codec.Object.mem "summary" Json.Codec.string ~enc:(fun e -> e.summary)
84
+
|> Json.Codec.Object.mem "changes" (Json.Codec.list Json.Codec.string)
85
+
~enc:(fun e -> e.changes)
86
+
|> Json.Codec.Object.mem "commit_range" commit_range_jsont ~enc:(fun e ->
87
87
e.commit_range)
88
-
|> Jsont.Object.mem "contributors" (Jsont.list Jsont.string) ~dec_absent:[]
89
-
~enc:(fun e -> e.contributors)
90
-
|> Jsont.Object.mem "repo_url" (Jsont.option Jsont.string) ~dec_absent:None
91
-
~enc:(fun e -> e.repo_url)
92
-
|> Jsont.Object.finish
88
+
|> Json.Codec.Object.mem "contributors" (Json.Codec.list Json.Codec.string)
89
+
~dec_absent:[] ~enc:(fun e -> e.contributors)
90
+
|> Json.Codec.Object.mem "repo_url" (Json.Codec.option Json.Codec.string)
91
+
~dec_absent:None ~enc:(fun e -> e.repo_url)
92
+
|> Json.Codec.Object.finish
93
93
94
94
type json_file = { json_repository : string; json_entries : file_entry list }
95
95
96
96
let json_file_jsont =
97
97
let make json_repository json_entries = { json_repository; json_entries } in
98
-
Jsont.Object.map ~kind:"daily_changes_file" make
99
-
|> Jsont.Object.mem "repository" Jsont.string ~enc:(fun f ->
98
+
Json.Codec.Object.map ~kind:"daily_changes_file" make
99
+
|> Json.Codec.Object.mem "repository" Json.Codec.string ~enc:(fun f ->
100
100
f.json_repository)
101
-
|> Jsont.Object.mem "entries" (Jsont.list file_entry_jsont) ~enc:(fun f ->
102
-
f.json_entries)
103
-
|> Jsont.Object.finish
101
+
|> Json.Codec.Object.mem "entries" (Json.Codec.list file_entry_jsont)
102
+
~enc:(fun f -> f.json_entries)
103
+
|> Json.Codec.Object.finish
104
104
105
105
(* Parse date from filename: <repo>-<YYYY-MM-DD>.json *)
106
106
let parse_daily_filename filename =
···
128
128
match Eio.Path.kind ~follow:true file_path with
129
129
| `Regular_file -> (
130
130
let content = Eio.Path.load file_path in
131
-
match Jsont_bytesrw.decode_string json_file_jsont content with
131
+
match Json.of_string json_file_jsont content with
132
132
| Ok jf ->
133
133
List.map
134
134
(fun (fe : file_entry) : entry ->
+1
-2
lib/dune
+1
-2
lib/dune
+7
-5
lib/fork_join.ml
+7
-5
lib/fork_join.ml
···
2
2
3
3
let src = Logs.Src.create "monopam.fork_join" ~doc:"Fork/join operations"
4
4
5
+
module Log = (val Logs.src_log src : Logs.LOG)
6
+
5
7
type error =
6
8
| Config_error of string
7
9
| Git_error of Git_cli.error
···
490
492
subtree from src/<name>/
491
493
492
494
This ensures the subtree relationship is properly established for sync. *)
493
-
let plan_fork ~sw ~proc ~fs ~config ~name ?push_url ?(dry_run = false) () =
495
+
let plan_fork ~sw ~fs ~config ~name ?push_url ?(dry_run = false) () =
494
496
let monorepo = Verse_config.mono_path config in
495
497
let checkouts = Verse_config.src_path config in
496
498
let prefix = name in
···
642
644
~name ~branch
643
645
644
646
(** Build a join plan - handles both URL and local path *)
645
-
let plan_join ~proc ~fs ~config ~source ?name ?upstream ?(dry_run = false) () =
647
+
let plan_join ~fs ~config ~source ?name ?upstream ?(dry_run = false) () =
646
648
let is_local = is_local_path source in
647
649
let name = match name with Some n -> n | None -> name_from_url source in
648
650
let monorepo = Verse_config.mono_path config in
···
704
706
(discovery, subtree_exists, src_exists, src_is_repo, opam_files_list)
705
707
706
708
(** Build a rejoin plan - add existing src/<name> back into mono/<name> *)
707
-
let plan_rejoin ~proc ~fs ~config ~name ?(dry_run = false) () =
709
+
let plan_rejoin ~fs ~config ~name ?(dry_run = false) () =
708
710
let monorepo = Verse_config.mono_path config in
709
711
let checkouts = Verse_config.src_path config in
710
712
let prefix = name in
···
944
946
with
945
947
| Ok () -> ()
946
948
| Error msg ->
947
-
Logs.warn (fun m -> m "Failed to update sources.toml: %s" msg))
949
+
Log.warn (fun m -> m "Failed to update sources.toml: %s" msg))
948
950
| None -> ()
949
951
950
952
let fork_add_push_remote ~sw ~fs ~src_path ~push_url =
···
1054
1056
with
1055
1057
| Ok () -> ()
1056
1058
| Error msg ->
1057
-
Logs.warn (fun m -> m "Failed to update sources.toml: %s" msg))
1059
+
Log.warn (fun m -> m "Failed to update sources.toml: %s" msg))
1058
1060
| None -> ()
1059
1061
1060
1062
let join_add_subtree ~sw ~proc ~fs ~monorepo ~prefix ~url ~branch =
+4
-8
lib/fork_join.mli
+4
-8
lib/fork_join.mli
···
138
138
139
139
val plan_fork :
140
140
sw:Eio.Switch.t ->
141
-
proc:_ Eio.Process.mgr ->
142
141
fs:Eio.Fs.dir_ty Eio.Path.t ->
143
142
config:Verse_config.t ->
144
143
name:string ->
···
146
145
?dry_run:bool ->
147
146
unit ->
148
147
(fork_result action_plan, error) result
149
-
(** [plan_fork ~sw ~proc ~fs ~config ~name ?push_url ?dry_run ()] builds a fork
150
-
plan.
148
+
(** [plan_fork ~sw ~fs ~config ~name ?push_url ?dry_run ()] builds a fork plan.
151
149
152
150
This analyzes the current state and builds a list of actions to:
153
151
- For subtrees with history: split subtree, create repo, push history
···
160
158
@param dry_run If true, mark plan as dry-run (execute will skip actions) *)
161
159
162
160
val plan_join :
163
-
proc:_ Eio.Process.mgr ->
164
161
fs:Eio.Fs.dir_ty Eio.Path.t ->
165
162
config:Verse_config.t ->
166
163
source:string ->
···
169
166
?dry_run:bool ->
170
167
unit ->
171
168
(join_result action_plan, error) result
172
-
(** [plan_join ~proc ~fs ~config ~source ?name ?upstream ?dry_run ()] builds a
173
-
join plan.
169
+
(** [plan_join ~fs ~config ~source ?name ?upstream ?dry_run ()] builds a join
170
+
plan.
174
171
175
172
This analyzes the source (URL or local path) and builds a list of actions
176
173
to:
···
186
183
@param dry_run If true, mark plan as dry-run (execute will skip actions) *)
187
184
188
185
val plan_rejoin :
189
-
proc:_ Eio.Process.mgr ->
190
186
fs:Eio.Fs.dir_ty Eio.Path.t ->
191
187
config:Verse_config.t ->
192
188
name:string ->
193
189
?dry_run:bool ->
194
190
unit ->
195
191
(join_result action_plan, error) result
196
-
(** [plan_rejoin ~proc ~fs ~config ~name ?dry_run ()] builds a rejoin plan.
192
+
(** [plan_rejoin ~fs ~config ~name ?dry_run ()] builds a rejoin plan.
197
193
198
194
This is used to add an existing src/<name>/ repository back into
199
195
mono/<name>/ as a subtree. Useful after forking a package and removing it
+4
-2
lib/git_cli.ml
+4
-2
lib/git_cli.ml
···
1
1
let src = Logs.Src.create "monopam.git_cli" ~doc:"Git CLI operations"
2
2
3
+
module Log = (val Logs.src_log src : Logs.LOG)
4
+
3
5
type cmd_result = { exit_code : int; stdout : string; stderr : string }
4
6
5
7
type error =
···
108
110
if result.exit_code = 0 then Ok result.stdout
109
111
else if n < max_retries && is_retryable_error result then begin
110
112
(* Log the retry (only with -v) *)
111
-
Logs.info (fun m ->
113
+
Log.info (fun m ->
112
114
m "Retrying in %dms (%d/%d)..." delay_ms (n + 1) max_retries);
113
115
(* Sleep before retry - convert ms to seconds for Unix.sleepf *)
114
116
Unix.sleepf (float_of_int delay_ms /. 1000.0);
···
249
251
let args =
250
252
[ "push" ] @ (if force then [ "--force" ] else []) @ [ url_str; refspec ]
251
253
in
252
-
Logs.debug (fun m -> m "push_refspec: git %s" (String.concat " " args));
254
+
Log.debug (fun m -> m "push_refspec: git %s" (String.concat " " args));
253
255
run_git_ok_with_retry ~proc ~cwd args |> Result.map ignore
254
256
255
257
let push_remote ~proc ~fs ?(remote = "origin") ?branch ?(force = false) path =
+3
-3
lib/lint.ml
+3
-3
lib/lint.ml
···
107
107
with Eio.Io _ -> None
108
108
109
109
(** Scan a lib directory for META files and populate the index. *)
110
-
let scan_meta_dir ~fs dir index =
110
+
let scan_meta_dir dir index =
111
111
let entries = try Eio.Path.read_dir dir with Eio.Io _ -> [] in
112
112
List.iter
113
113
(fun pkg ->
···
135
135
let opam_lib =
136
136
Eio.Path.(fs / Fpath.to_string Fpath.(monorepo / "_opam" / "lib"))
137
137
in
138
-
scan_meta_dir ~fs build_lib index;
139
-
scan_meta_dir ~fs opam_lib index;
138
+
scan_meta_dir build_lib index;
139
+
scan_meta_dir opam_lib index;
140
140
Log.debug (fun m -> m "Library index: %d entries" (Hashtbl.length index));
141
141
index
142
142
+3
-2
lib/progress.ml
+3
-2
lib/progress.ml
···
18
18
{ progress; completed = Atomic.make 0; total; phase_name }
19
19
20
20
let tick t name =
21
-
let _n = Atomic.fetch_and_add t.completed 1 + 1 in
22
-
Tty.Progress.update t.progress ~phase:t.phase_name ~msg:name
21
+
let n = Atomic.fetch_and_add t.completed 1 + 1 in
22
+
let msg = Fmt.str "%s (%d/%d)" name n t.total in
23
+
Tty.Progress.update t.progress ~phase:t.phase_name ~msg
23
24
24
25
let clear t = Tty.Progress.clear t.progress
25
26
let finish t = Tty.Progress.finish t.progress
+7
-8
lib/push.ml
+7
-8
lib/push.ml
···
371
371
372
372
type missing_repo = { pkg : Package.t; url : string }
373
373
374
-
let export_repos ~sw ~proc ~fs ~config ~sources ~clean ~force ~progress repos =
374
+
let export_repos ~proc ~fs ~config ~sources ~clean ~force ~progress repos =
375
375
let update_progress name =
376
376
Tty.Progress.update progress ~phase:"Export" ~msg:name
377
377
in
···
395
395
in
396
396
loop [] [] repos
397
397
398
-
let to_upstream ~sw ~proc ~fs ~config ~sources ~force ~progress pushed_repos =
398
+
let to_upstream ~proc ~fs ~config ~sources ~force ~progress pushed_repos =
399
399
Log.info (fun m ->
400
400
m "Pushing %d repos to configured remotes (parallel)"
401
401
(List.length pushed_repos));
···
744
744
Ok (name, url))
745
745
repos
746
746
747
-
let to_checkout_results ~sw ~proc ~fs_t ~config ~sources ~upstream ~force
748
-
~progress pushed_repos =
747
+
let to_checkout_results ~proc ~fs_t ~config ~sources ~upstream ~force ~progress
748
+
pushed_repos =
749
749
if upstream && pushed_repos <> [] then
750
-
to_upstream ~sw ~proc ~fs:fs_t ~config ~sources ~force ~progress
751
-
pushed_repos
750
+
to_upstream ~proc ~fs:fs_t ~config ~sources ~force ~progress pushed_repos
752
751
else local_results ~config pushed_repos
753
752
754
753
let workspace_check ~sw ~proc ~fs_t ~config ~force ~push_mono ~upstream =
···
779
778
in
780
779
Tty_eio.Progress.animate ~sw ~clock progress;
781
780
match
782
-
export_repos ~sw ~proc ~fs ~config ~sources ~clean ~force ~progress repos
781
+
export_repos ~proc ~fs ~config ~sources ~clean ~force ~progress repos
783
782
with
784
783
| Error e ->
785
784
Tty.Progress.finish progress;
786
785
Error e
787
786
| Ok (pushed_repos, missing) -> (
788
787
let results =
789
-
to_checkout_results ~sw ~proc ~fs_t ~config ~sources ~upstream ~force
788
+
to_checkout_results ~proc ~fs_t ~config ~sources ~upstream ~force
790
789
~progress pushed_repos
791
790
in
792
791
Tty.Progress.finish ~message:"exported" progress;
+3
-2
lib/sync_progress.ml
+3
-2
lib/sync_progress.ml
···
18
18
{ progress; completed = Atomic.make 0; total; phase_name }
19
19
20
20
let tick t name =
21
-
let _n = Atomic.fetch_and_add t.completed 1 + 1 in
22
-
Tty.Progress.update t.progress ~phase:t.phase_name ~msg:name
21
+
let n = Atomic.fetch_and_add t.completed 1 + 1 in
22
+
let msg = Fmt.str "%s (%d/%d)" name n t.total in
23
+
Tty.Progress.update t.progress ~phase:t.phase_name ~msg
23
24
24
25
let clear t = Tty.Progress.clear t.progress
25
26
let finish t = Tty.Progress.finish t.progress
+27
-26
lib/verse.ml
+27
-26
lib/verse.ml
···
1
1
let src = Logs.Src.create "monopam.verse" ~doc:"Verse operations"
2
2
3
+
module Log = (val Logs.src_log src : Logs.LOG)
4
+
3
5
type error =
4
6
| Config_error of string
5
7
| Git_error of Git_cli.error
···
153
155
ensure_dir ~fs (Verse_config.src_path config);
154
156
ensure_dir ~fs (Verse_config.verse_path config);
155
157
let mono_path = Verse_config.mono_path config in
156
-
Logs.info (fun m -> m "Cloning monorepo to %a" Fpath.pp mono_path);
158
+
Log.info (fun m -> m "Cloning monorepo to %a" Fpath.pp mono_path);
157
159
match
158
160
Git_cli.clone ~proc ~fs ~url:member.Verse_registry.monorepo
159
161
~branch:Verse_config.default_branch mono_path
160
162
with
161
163
| Error e ->
162
-
Logs.err (fun m -> m "Monorepo clone failed: %a" Git_cli.pp_error e);
164
+
Log.err (fun m -> m "Monorepo clone failed: %a" Git_cli.pp_error e);
163
165
Error (Git_error e)
164
166
| Ok () -> (
165
-
Logs.info (fun m -> m "Monorepo cloned");
167
+
Log.info (fun m -> m "Monorepo cloned");
166
168
let opam_path = Verse_config.opam_repo_path config in
167
-
Logs.info (fun m -> m "Cloning opam repo to %a" Fpath.pp opam_path);
169
+
Log.info (fun m -> m "Cloning opam repo to %a" Fpath.pp opam_path);
168
170
match
169
171
Git_cli.clone ~proc ~fs ~url:member.Verse_registry.opamrepo
170
172
~branch:Verse_config.default_branch opam_path
171
173
with
172
174
| Error e ->
173
-
Logs.err (fun m -> m "Opam repo clone failed: %a" Git_cli.pp_error e);
175
+
Log.err (fun m -> m "Opam repo clone failed: %a" Git_cli.pp_error e);
174
176
Error (Git_error e)
175
177
| Ok () ->
176
-
Logs.info (fun m -> m "Opam repo cloned");
178
+
Log.info (fun m -> m "Opam repo cloned");
177
179
Ok ())
178
180
179
181
let init ~sw ~proc ~fs ~root ~handle () =
180
182
let config_file = Verse_config.file () in
181
-
Logs.info (fun m -> m "Config file: %a" Fpath.pp config_file);
183
+
Log.info (fun m -> m "Config file: %a" Fpath.pp config_file);
182
184
if is_file ~fs config_file then begin
183
-
Logs.app (fun m -> m "[init] verse: already configured, skipping");
185
+
Log.app (fun m -> m "[init] verse: already configured, skipping");
184
186
Ok ()
185
187
end
186
188
else
187
189
let root = resolve_root ~fs root in
188
-
Logs.info (fun m -> m "Workspace root: %a" Fpath.pp root);
190
+
Log.info (fun m -> m "Workspace root: %a" Fpath.pp root);
189
191
let config = Verse_config.v ~root ~handle () in
190
-
Logs.info (fun m -> m "Cloning registry...");
192
+
Log.info (fun m -> m "Cloning registry...");
191
193
match Verse_registry.clone_or_pull ~sw ~proc ~fs ~config () with
192
194
| Error msg ->
193
-
Logs.err (fun m -> m "Registry clone failed: %s" msg);
195
+
Log.err (fun m -> m "Registry clone failed: %s" msg);
194
196
Error (Registry_error msg)
195
197
| Ok registry -> (
196
-
Logs.info (fun m -> m "Registry loaded");
198
+
Log.info (fun m -> m "Registry loaded");
197
199
match Verse_registry.member registry ~handle with
198
200
| None -> (
199
-
Logs.app (fun m ->
201
+
Log.app (fun m ->
200
202
m "[init] verse: handle %s not found in registry, skipping"
201
203
handle);
202
204
(* Save config anyway so init is not re-attempted *)
203
205
match Verse_config.save ~fs config with
204
206
| Error msg ->
205
-
Logs.err (fun m -> m "Failed to save config: %s" msg);
207
+
Log.err (fun m -> m "Failed to save config: %s" msg);
206
208
Error (Config_error msg)
207
209
| Ok () -> Ok ())
208
210
| Some member -> (
209
-
Logs.info (fun m ->
211
+
Log.info (fun m ->
210
212
m "Found member: mono=%s opam=%s" member.monorepo
211
213
member.opamrepo);
212
-
Logs.info (fun m -> m "Creating workspace directories...");
214
+
Log.info (fun m -> m "Creating workspace directories...");
213
215
match clone_workspace_repos ~proc ~fs ~config ~member with
214
216
| Error e -> Error e
215
217
| Ok () -> (
216
-
Logs.info (fun m ->
217
-
m "Saving config to %a" Fpath.pp config_file);
218
+
Log.info (fun m -> m "Saving config to %a" Fpath.pp config_file);
218
219
match Verse_config.save ~fs config with
219
220
| Error msg ->
220
-
Logs.err (fun m -> m "Failed to save config: %s" msg);
221
+
Log.err (fun m -> m "Failed to save config: %s" msg);
221
222
Error (Config_error msg)
222
223
| Ok () ->
223
-
Logs.info (fun m -> m "Workspace initialized successfully");
224
+
Log.info (fun m -> m "Workspace initialized successfully");
224
225
Ok ())))
225
226
226
227
let status ~sw ~proc ~fs ~config () =
···
300
301
let sync_repo_result ~label h result =
301
302
match result with
302
303
| Ok true ->
303
-
Logs.info (fun m -> m " Cloned %s %s" h label);
304
+
Log.info (fun m -> m " Cloned %s %s" h label);
304
305
None
305
306
| Ok false ->
306
-
Logs.info (fun m -> m " Reset %s %s" h label);
307
+
Log.info (fun m -> m " Reset %s %s" h label);
307
308
None
308
309
| Error e ->
309
-
Logs.warn (fun m -> m " Failed %s %s: %a" h label Git_cli.pp_error e);
310
+
Log.warn (fun m -> m " Failed %s %s: %a" h label Git_cli.pp_error e);
310
311
Some (Fmt.str "%s %s: %a" h label Git_cli.pp_error e)
311
312
312
313
let sync_member ~proc ~fs ~verse_dir (member : Verse_registry.member) =
313
314
let h = member.handle in
314
315
let mono_path = Fpath.(verse_dir / h) in
315
316
let opam_path = Fpath.(verse_dir / (h ^ "-opam")) in
316
-
Logs.info (fun m -> m "Syncing %s monorepo" h);
317
+
Log.info (fun m -> m "Syncing %s monorepo" h);
317
318
let mono_branch =
318
319
Option.value ~default:Verse_config.default_branch member.monorepo_branch
319
320
in
···
322
323
mono_path
323
324
in
324
325
let mono_err = sync_repo_result ~label:"monorepo" h mono_result in
325
-
Logs.info (fun m -> m "Syncing %s opam repo" h);
326
+
Log.info (fun m -> m "Syncing %s opam repo" h);
326
327
let opam_branch =
327
328
Option.value ~default:Verse_config.default_branch member.opamrepo_branch
328
329
in
···
353
354
else begin
354
355
let verse_dir = Verse_config.verse_path config in
355
356
ensure_dir ~fs verse_dir;
356
-
Logs.info (fun m -> m "Syncing %d members" (List.length members));
357
+
Log.info (fun m -> m "Syncing %d members" (List.length members));
357
358
let errors =
358
359
Eio.Fiber.List.filter_map ~max_fibers:4
359
360
(sync_member ~proc ~fs ~verse_dir)
+16
-14
lib/verse_registry.ml
+16
-14
lib/verse_registry.ml
···
1
1
let src = Logs.Src.create "monopam.verse_registry" ~doc:"Verse registry"
2
2
3
+
module Log = (val Logs.src_log src : Logs.LOG)
4
+
3
5
type member = {
4
6
handle : string;
5
7
name : string option;
···
102
104
103
105
let load ~fs path =
104
106
let path_str = Fpath.to_string path in
105
-
Logs.info (fun m -> m "Loading registry from path: %s" path_str);
107
+
Log.info (fun m -> m "Loading registry from path: %s" path_str);
106
108
try
107
109
let registry = Toml_eio.decode_path_exn codec ~fs path_str in
108
-
Logs.info (fun m ->
110
+
Log.info (fun m ->
109
111
m "Registry loaded: %d members" (List.length registry.members));
110
112
Ok registry
111
113
with
112
114
| Eio.Io _ as e ->
113
-
Logs.err (fun m -> m "Eio.Io error: %s" (Printexc.to_string e));
115
+
Log.err (fun m -> m "Eio.Io error: %s" (Printexc.to_string e));
114
116
err_io e
115
117
| Failure msg ->
116
-
Logs.err (fun m -> m "Registry parse error: %s" msg);
118
+
Log.err (fun m -> m "Registry parse error: %s" msg);
117
119
err_invalid msg
118
120
| exn ->
119
-
Logs.err (fun m ->
121
+
Log.err (fun m ->
120
122
m "Unexpected registry error: %s" (Printexc.to_string exn));
121
123
err_other exn
122
124
···
130
132
let clone_or_pull ~sw ~proc ~fs ~config:_ () =
131
133
let registry_path = Verse_config.registry_path () in
132
134
let registry_toml = Fpath.(registry_path / "opamverse.toml") in
133
-
Logs.info (fun m -> m "Registry path: %a" Fpath.pp registry_path);
135
+
Log.info (fun m -> m "Registry path: %a" Fpath.pp registry_path);
134
136
(* Check if registry directory exists as a git repo *)
135
137
let exists =
136
138
let path = Eio.Path.(fs / Fpath.to_string registry_path) in
···
140
142
| exception _ -> false
141
143
in
142
144
if exists then begin
143
-
Logs.info (fun m -> m "Registry exists, pulling updates...");
145
+
Log.info (fun m -> m "Registry exists, pulling updates...");
144
146
(* Pull updates, but don't fail if pull fails *)
145
147
(match Git_cli.pull ~proc ~fs registry_path with
146
-
| Ok () -> Logs.info (fun m -> m "Registry pull succeeded")
148
+
| Ok () -> Log.info (fun m -> m "Registry pull succeeded")
147
149
| Error e ->
148
-
Logs.warn (fun m ->
150
+
Log.warn (fun m ->
149
151
m "Registry pull failed: %a (using cached)" Git_cli.pp_error e));
150
-
Logs.info (fun m -> m "Loading registry from %a" Fpath.pp registry_toml);
152
+
Log.info (fun m -> m "Loading registry from %a" Fpath.pp registry_toml);
151
153
load ~fs registry_toml
152
154
end
153
155
else begin
154
-
Logs.info (fun m -> m "Registry not found, cloning from %s..." default_url);
156
+
Log.info (fun m -> m "Registry not found, cloning from %s..." default_url);
155
157
(* Ensure parent directory exists *)
156
158
let parent = Fpath.parent registry_path in
157
159
let parent_path = Eio.Path.(fs / Fpath.to_string parent) in
···
160
162
let branch = "main" in
161
163
match Git_cli.clone ~proc ~fs ~url:default_url ~branch registry_path with
162
164
| Ok () ->
163
-
Logs.info (fun m -> m "Registry cloned successfully");
165
+
Log.info (fun m -> m "Registry cloned successfully");
164
166
load ~fs registry_toml
165
167
| Error e ->
166
-
Logs.warn (fun m -> m "Registry clone failed: %a" Git_cli.pp_error e);
167
-
Logs.info (fun m -> m "Creating empty local registry...");
168
+
Log.warn (fun m -> m "Registry clone failed: %a" Git_cli.pp_error e);
169
+
Log.info (fun m -> m "Creating empty local registry...");
168
170
(* Clone failed - create local registry directory with empty registry *)
169
171
let registry_eio = Eio.Path.(fs / Fpath.to_string registry_path) in
170
172
(try Eio.Path.mkdirs ~perm:0o755 registry_eio with Eio.Io _ -> ());
+1
-1
monopam.opam
+1
-1
monopam.opam
+2
-1
test/test_auto_resolve.ml
+2
-1
test/test_auto_resolve.ml
···
15
15
client.AR.resolve_one ~path:"f" ~base:None ~ours:"" ~theirs:"" ~chunks
16
16
with
17
17
| Ok p -> p.AR.merged
18
-
| Error e -> Alcotest.failf "client returned error: %s" e
18
+
| Error e ->
19
+
Alcotest.failf "client returned error: %s" e
19
20
20
21
let test_ours_picks_ours () =
21
22
let chunks =
+2
-1
test/test_deps.ml
+2
-1
test/test_deps.ml
···
30
30
let path = Fpath.(target / "sources.toml") in
31
31
match SR.save ~fs path sources with
32
32
| Ok () -> ()
33
-
| Error e -> Alcotest.failf "failed to write sources.toml: %s" e
33
+
| Error e ->
34
+
Alcotest.failf "failed to write sources.toml: %s" e
34
35
35
36
let result_testable =
36
37
Alcotest.testable