My agentic slop goes here. Not intended for anyone else!
anil.recoil.org
1let src = Logs.Src.create "claude.message" ~doc:"Claude messages"
2module Log = (val Logs.src_log src : Logs.LOG)
3
4
5module User = struct
6 type content =
7 | String of string
8 | Blocks of Content_block.t list
9
10 type t = {
11 content : content;
12 unknown : Unknown.t;
13 }
14
15 let create_string s = { content = String s; unknown = Unknown.empty }
16 let create_blocks blocks = { content = Blocks blocks; unknown = Unknown.empty }
17
18 let create_with_tool_result ~tool_use_id ~content ?is_error () =
19 let tool_result = Content_block.tool_result ~tool_use_id ~content ?is_error () in
20 { content = Blocks [tool_result]; unknown = Unknown.empty }
21
22 let create_mixed ~text ~tool_results =
23 let blocks =
24 let text_blocks = match text with
25 | Some t -> [Content_block.text t]
26 | None -> []
27 in
28 let tool_blocks = List.map (fun (tool_use_id, content, is_error) ->
29 Content_block.tool_result ~tool_use_id ~content ?is_error ()
30 ) tool_results in
31 text_blocks @ tool_blocks
32 in
33 { content = Blocks blocks; unknown = Unknown.empty }
34
35 let make content unknown = { content; unknown }
36 let content t = t.content
37 let unknown t = t.unknown
38
39 let as_text t = match t.content with
40 | String s -> Some s
41 | Blocks _ -> None
42
43 let get_blocks t = match t.content with
44 | String s -> [Content_block.text s]
45 | Blocks blocks -> blocks
46
47 (* Decode content from json value *)
48 let decode_content json = match json with
49 | Jsont.String (s, _) -> String s
50 | Jsont.Array (items, _) ->
51 let blocks = List.map (fun j ->
52 match Jsont.Json.decode Content_block.jsont j with
53 | Ok b -> b
54 | Error msg -> failwith ("Invalid content block: " ^ msg)
55 ) items in
56 Blocks blocks
57 | _ -> failwith "Content must be string or array"
58
59 (* Encode content to json value *)
60 let encode_content = function
61 | String s -> Jsont.String (s, Jsont.Meta.none)
62 | Blocks blocks -> Jsont.Array (List.map Content_block.to_json blocks, Jsont.Meta.none)
63
64 let jsont : t Jsont.t =
65 Jsont.Object.map ~kind:"User" (fun json_content unknown ->
66 let content = decode_content json_content in
67 make content unknown
68 )
69 |> Jsont.Object.mem "content" Jsont.json ~enc:(fun t -> encode_content (content t))
70 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
71 |> Jsont.Object.finish
72
73 let to_json t =
74 let content_json = match t.content with
75 | String s -> Jsont.String (s, Jsont.Meta.none)
76 | Blocks blocks ->
77 Jsont.Array (List.map Content_block.to_json blocks, Jsont.Meta.none)
78 in
79 Jsont.Object ([
80 (Jsont.Json.name "type", Jsont.String ("user", Jsont.Meta.none));
81 (Jsont.Json.name "message", Jsont.Object ([
82 (Jsont.Json.name "role", Jsont.String ("user", Jsont.Meta.none));
83 (Jsont.Json.name "content", content_json);
84 ], Jsont.Meta.none));
85 ], Jsont.Meta.none)
86
87 (* Jsont codec for parsing incoming user messages from CLI *)
88 let incoming_jsont : t Jsont.t =
89 let message_jsont =
90 Jsont.Object.map ~kind:"UserMessage" (fun json_content ->
91 let content = decode_content json_content in
92 { content; unknown = Unknown.empty }
93 )
94 |> Jsont.Object.mem "content" Jsont.json ~enc:(fun t -> encode_content (content t))
95 |> Jsont.Object.finish
96 in
97 Jsont.Object.map ~kind:"UserEnvelope" Fun.id
98 |> Jsont.Object.mem "message" message_jsont ~enc:Fun.id
99 |> Jsont.Object.finish
100
101 let of_json json =
102 match Jsont.Json.decode incoming_jsont json with
103 | Ok v -> v
104 | Error msg -> raise (Invalid_argument ("User.of_json: " ^ msg))
105
106 let pp fmt t =
107 match t.content with
108 | String s ->
109 if String.length s > 60 then
110 let truncated = String.sub s 0 57 in
111 Fmt.pf fmt "@[<2>User:@ %s...@]" truncated
112 else
113 Fmt.pf fmt "@[<2>User:@ %S@]" s
114 | Blocks blocks ->
115 let text_count = List.length (List.filter (function
116 | Content_block.Text _ -> true | _ -> false) blocks) in
117 let tool_result_count = List.length (List.filter (function
118 | Content_block.Tool_result _ -> true | _ -> false) blocks) in
119 match text_count, tool_result_count with
120 | 1, 0 ->
121 let text = List.find_map (function
122 | Content_block.Text t -> Some (Content_block.Text.text t)
123 | _ -> None) blocks in
124 Fmt.pf fmt "@[<2>User:@ %a@]" Fmt.(option string) text
125 | 0, 1 ->
126 Fmt.pf fmt "@[<2>User:@ [tool result]@]"
127 | 0, n when n > 1 ->
128 Fmt.pf fmt "@[<2>User:@ [%d tool results]@]" n
129 | _ ->
130 Fmt.pf fmt "@[<2>User:@ [%d blocks]@]" (List.length blocks)
131end
132
133module Assistant = struct
134 type error = [
135 | `Authentication_failed
136 | `Billing_error
137 | `Rate_limit
138 | `Invalid_request
139 | `Server_error
140 | `Unknown
141 ]
142
143 let error_to_string = function
144 | `Authentication_failed -> "authentication_failed"
145 | `Billing_error -> "billing_error"
146 | `Rate_limit -> "rate_limit"
147 | `Invalid_request -> "invalid_request"
148 | `Server_error -> "server_error"
149 | `Unknown -> "unknown"
150
151 let error_of_string = function
152 | "authentication_failed" -> `Authentication_failed
153 | "billing_error" -> `Billing_error
154 | "rate_limit" -> `Rate_limit
155 | "invalid_request" -> `Invalid_request
156 | "server_error" -> `Server_error
157 | "unknown" | _ -> `Unknown
158
159 let error_jsont : error Jsont.t =
160 Jsont.enum [
161 ("authentication_failed", `Authentication_failed);
162 ("billing_error", `Billing_error);
163 ("rate_limit", `Rate_limit);
164 ("invalid_request", `Invalid_request);
165 ("server_error", `Server_error);
166 ("unknown", `Unknown);
167 ]
168
169 type t = {
170 content : Content_block.t list;
171 model : string;
172 error : error option;
173 unknown : Unknown.t;
174 }
175
176 let create ~content ~model ?error () = { content; model; error; unknown = Unknown.empty }
177 let make content model error unknown = { content; model; error; unknown }
178 let content t = t.content
179 let model t = t.model
180 let error t = t.error
181 let unknown t = t.unknown
182
183 let get_text_blocks t =
184 List.filter_map (function
185 | Content_block.Text text -> Some (Content_block.Text.text text)
186 | _ -> None
187 ) t.content
188
189 let get_tool_uses t =
190 List.filter_map (function
191 | Content_block.Tool_use tool -> Some tool
192 | _ -> None
193 ) t.content
194
195 let get_thinking t =
196 List.filter_map (function
197 | Content_block.Thinking thinking -> Some thinking
198 | _ -> None
199 ) t.content
200
201 let has_tool_use t =
202 List.exists (function
203 | Content_block.Tool_use _ -> true
204 | _ -> false
205 ) t.content
206
207 let combined_text t =
208 String.concat "\n" (get_text_blocks t)
209
210 let jsont : t Jsont.t =
211 Jsont.Object.map ~kind:"Assistant" make
212 |> Jsont.Object.mem "content" (Jsont.list Content_block.jsont) ~enc:content
213 |> Jsont.Object.mem "model" Jsont.string ~enc:model
214 |> Jsont.Object.opt_mem "error" error_jsont ~enc:error
215 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
216 |> Jsont.Object.finish
217
218 let to_json t =
219 let msg_fields = [
220 (Jsont.Json.name "content", Jsont.Array (List.map Content_block.to_json t.content, Jsont.Meta.none));
221 (Jsont.Json.name "model", Jsont.String (t.model, Jsont.Meta.none));
222 ] in
223 let msg_fields = match t.error with
224 | Some err -> (Jsont.Json.name "error", Jsont.String (error_to_string err, Jsont.Meta.none)) :: msg_fields
225 | None -> msg_fields
226 in
227 Jsont.Object ([
228 (Jsont.Json.name "type", Jsont.String ("assistant", Jsont.Meta.none));
229 (Jsont.Json.name "message", Jsont.Object (msg_fields, Jsont.Meta.none));
230 ], Jsont.Meta.none)
231
232 (* Jsont codec for parsing incoming assistant messages from CLI *)
233 let incoming_jsont : t Jsont.t =
234 Jsont.Object.map ~kind:"AssistantEnvelope" Fun.id
235 |> Jsont.Object.mem "message" jsont ~enc:Fun.id
236 |> Jsont.Object.finish
237
238 let of_json json =
239 match Jsont.Json.decode incoming_jsont json with
240 | Ok v -> v
241 | Error msg -> raise (Invalid_argument ("Assistant.of_json: " ^ msg))
242
243 let pp fmt t =
244 let text_count = List.length (get_text_blocks t) in
245 let tool_count = List.length (get_tool_uses t) in
246 let thinking_count = List.length (get_thinking t) in
247 match text_count, tool_count, thinking_count with
248 | 1, 0, 0 ->
249 (* Simple text response *)
250 Fmt.pf fmt "@[<2>Assistant@ [%s]:@ %S@]"
251 t.model (combined_text t)
252 | _, 0, 0 when text_count > 0 ->
253 (* Multiple text blocks *)
254 Fmt.pf fmt "@[<2>Assistant@ [%s]:@ %d text blocks@]"
255 t.model text_count
256 | 0, _, 0 when tool_count > 0 ->
257 (* Only tool uses *)
258 let tools = get_tool_uses t in
259 let tool_names = List.map Content_block.Tool_use.name tools in
260 Fmt.pf fmt "@[<2>Assistant@ [%s]:@ tools(%a)@]"
261 t.model Fmt.(list ~sep:comma string) tool_names
262 | _ ->
263 (* Mixed content *)
264 let parts = [] in
265 let parts = if text_count > 0 then
266 Printf.sprintf "%d text" text_count :: parts else parts in
267 let parts = if tool_count > 0 then
268 Printf.sprintf "%d tools" tool_count :: parts else parts in
269 let parts = if thinking_count > 0 then
270 Printf.sprintf "%d thinking" thinking_count :: parts else parts in
271 Fmt.pf fmt "@[<2>Assistant@ [%s]:@ %s@]"
272 t.model (String.concat ", " (List.rev parts))
273end
274
275module System = struct
276 (** System messages as a discriminated union on "subtype" field *)
277
278 type init = {
279 session_id : string option;
280 model : string option;
281 cwd : string option;
282 unknown : Unknown.t;
283 }
284
285 type error = {
286 error : string;
287 unknown : Unknown.t;
288 }
289
290 type other = {
291 subtype : string;
292 unknown : Unknown.t;
293 }
294
295 type t =
296 | Init of init
297 | Error of error
298 | Other of other
299
300 (* Accessors *)
301 let session_id = function Init i -> i.session_id | _ -> None
302 let model = function Init i -> i.model | _ -> None
303 let cwd = function Init i -> i.cwd | _ -> None
304 let error_msg = function Error e -> Some e.error | _ -> None
305 let subtype = function Init _ -> "init" | Error _ -> "error" | Other o -> o.subtype
306 let unknown = function
307 | Init i -> i.unknown
308 | Error e -> e.unknown
309 | Other o -> o.unknown
310
311 (* Constructors *)
312 let init ?session_id ?model ?cwd () =
313 Init { session_id; model; cwd; unknown = Unknown.empty }
314
315 let error ~error =
316 Error { error; unknown = Unknown.empty }
317
318 let other ~subtype =
319 Other { subtype; unknown = Unknown.empty }
320
321 (* Individual record codecs *)
322 let init_jsont : init Jsont.t =
323 let make session_id model cwd unknown : init = { session_id; model; cwd; unknown } in
324 Jsont.Object.map ~kind:"SystemInit" make
325 |> Jsont.Object.opt_mem "session_id" Jsont.string ~enc:(fun (r : init) -> r.session_id)
326 |> Jsont.Object.opt_mem "model" Jsont.string ~enc:(fun (r : init) -> r.model)
327 |> Jsont.Object.opt_mem "cwd" Jsont.string ~enc:(fun (r : init) -> r.cwd)
328 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : init) -> r.unknown)
329 |> Jsont.Object.finish
330
331 let error_jsont : error Jsont.t =
332 let make err unknown : error = { error = err; unknown } in
333 Jsont.Object.map ~kind:"SystemError" make
334 |> Jsont.Object.mem "error" Jsont.string ~enc:(fun (r : error) -> r.error)
335 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : error) -> r.unknown)
336 |> Jsont.Object.finish
337
338 (* Main codec using case_mem for "subtype" discriminator *)
339 let jsont : t Jsont.t =
340 let case_init = Jsont.Object.Case.map "init" init_jsont ~dec:(fun v -> Init v) in
341 let case_error = Jsont.Object.Case.map "error" error_jsont ~dec:(fun v -> Error v) in
342 let case_other tag =
343 (* For unknown subtypes, create Other with the tag as subtype *)
344 let other_codec : other Jsont.t =
345 let make unknown : other = { subtype = tag; unknown } in
346 Jsont.Object.map ~kind:"SystemOther" make
347 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : other) -> r.unknown)
348 |> Jsont.Object.finish
349 in
350 Jsont.Object.Case.map tag other_codec ~dec:(fun v -> Other v)
351 in
352 let enc_case = function
353 | Init v -> Jsont.Object.Case.value case_init v
354 | Error v -> Jsont.Object.Case.value case_error v
355 | Other v -> Jsont.Object.Case.value (case_other v.subtype) v
356 in
357 let cases = Jsont.Object.Case.[
358 make case_init;
359 make case_error;
360 ] in
361 Jsont.Object.map ~kind:"System" Fun.id
362 |> Jsont.Object.case_mem "subtype" Jsont.string ~enc:Fun.id ~enc_case cases
363 ~tag_to_string:Fun.id ~tag_compare:String.compare
364 |> Jsont.Object.finish
365
366 let to_json t =
367 match Jsont.Json.encode jsont t with
368 | Ok json -> json
369 | Error msg -> failwith ("System.to_json: " ^ msg)
370
371 let of_json json =
372 match Jsont.Json.decode jsont json with
373 | Ok v -> v
374 | Error msg -> raise (Invalid_argument ("System.of_json: " ^ msg))
375
376 let pp fmt = function
377 | Init i ->
378 Fmt.pf fmt "@[<2>System.init@ { session_id = %a;@ model = %a;@ cwd = %a }@]"
379 Fmt.(option string) i.session_id
380 Fmt.(option string) i.model
381 Fmt.(option string) i.cwd
382 | Error e ->
383 Fmt.pf fmt "@[<2>System.error@ { error = %s }@]" e.error
384 | Other o ->
385 Fmt.pf fmt "@[<2>System.%s@ { ... }@]" o.subtype
386end
387
388module Result = struct
389 module Usage = struct
390 type t = {
391 input_tokens : int option;
392 output_tokens : int option;
393 total_tokens : int option;
394 cache_creation_input_tokens : int option;
395 cache_read_input_tokens : int option;
396 unknown : Unknown.t;
397 }
398
399 let make input_tokens output_tokens total_tokens
400 cache_creation_input_tokens cache_read_input_tokens unknown =
401 { input_tokens; output_tokens; total_tokens;
402 cache_creation_input_tokens; cache_read_input_tokens; unknown }
403
404 let create ?input_tokens ?output_tokens ?total_tokens
405 ?cache_creation_input_tokens ?cache_read_input_tokens () =
406 { input_tokens; output_tokens; total_tokens;
407 cache_creation_input_tokens; cache_read_input_tokens;
408 unknown = Unknown.empty }
409
410 let input_tokens t = t.input_tokens
411 let output_tokens t = t.output_tokens
412 let total_tokens t = t.total_tokens
413 let cache_creation_input_tokens t = t.cache_creation_input_tokens
414 let cache_read_input_tokens t = t.cache_read_input_tokens
415 let unknown t = t.unknown
416
417 let jsont : t Jsont.t =
418 Jsont.Object.map ~kind:"Usage" make
419 |> Jsont.Object.opt_mem "input_tokens" Jsont.int ~enc:input_tokens
420 |> Jsont.Object.opt_mem "output_tokens" Jsont.int ~enc:output_tokens
421 |> Jsont.Object.opt_mem "total_tokens" Jsont.int ~enc:total_tokens
422 |> Jsont.Object.opt_mem "cache_creation_input_tokens" Jsont.int ~enc:cache_creation_input_tokens
423 |> Jsont.Object.opt_mem "cache_read_input_tokens" Jsont.int ~enc:cache_read_input_tokens
424 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
425 |> Jsont.Object.finish
426
427 let effective_input_tokens t =
428 match t.input_tokens with
429 | None -> 0
430 | Some input ->
431 let cached = Option.value t.cache_read_input_tokens ~default:0 in
432 max 0 (input - cached)
433
434 let total_cost_estimate t ~input_price ~output_price =
435 match t.input_tokens, t.output_tokens with
436 | Some input, Some output ->
437 let input_cost = float_of_int input *. input_price /. 1_000_000. in
438 let output_cost = float_of_int output *. output_price /. 1_000_000. in
439 Some (input_cost +. output_cost)
440 | _ -> None
441
442 let pp fmt t =
443 Fmt.pf fmt "@[<2>Usage@ { input = %a;@ output = %a;@ total = %a;@ \
444 cache_creation = %a;@ cache_read = %a }@]"
445 Fmt.(option int) t.input_tokens
446 Fmt.(option int) t.output_tokens
447 Fmt.(option int) t.total_tokens
448 Fmt.(option int) t.cache_creation_input_tokens
449 Fmt.(option int) t.cache_read_input_tokens
450
451 let to_json t =
452 match Jsont.Json.encode jsont t with
453 | Ok json -> json
454 | Error msg -> failwith ("Usage.to_json: " ^ msg)
455
456 let of_json json =
457 match Jsont.Json.decode jsont json with
458 | Ok v -> v
459 | Error msg -> raise (Invalid_argument ("Usage.of_json: " ^ msg))
460 end
461
462 type t = {
463 subtype : string;
464 duration_ms : int;
465 duration_api_ms : int;
466 is_error : bool;
467 num_turns : int;
468 session_id : string;
469 total_cost_usd : float option;
470 usage : Usage.t option;
471 result : string option;
472 structured_output : Jsont.json option;
473 unknown : Unknown.t;
474 }
475
476 let create ~subtype ~duration_ms ~duration_api_ms ~is_error ~num_turns
477 ~session_id ?total_cost_usd ?usage ?result ?structured_output () =
478 { subtype; duration_ms; duration_api_ms; is_error; num_turns;
479 session_id; total_cost_usd; usage; result; structured_output; unknown = Unknown.empty }
480
481 let make subtype duration_ms duration_api_ms is_error num_turns
482 session_id total_cost_usd usage result structured_output unknown =
483 { subtype; duration_ms; duration_api_ms; is_error; num_turns;
484 session_id; total_cost_usd; usage; result; structured_output; unknown }
485
486 let subtype t = t.subtype
487 let duration_ms t = t.duration_ms
488 let duration_api_ms t = t.duration_api_ms
489 let is_error t = t.is_error
490 let num_turns t = t.num_turns
491 let session_id t = t.session_id
492 let total_cost_usd t = t.total_cost_usd
493 let usage t = t.usage
494 let result t = t.result
495 let structured_output t = t.structured_output
496 let unknown t = t.unknown
497
498 let jsont : t Jsont.t =
499 Jsont.Object.map ~kind:"Result" make
500 |> Jsont.Object.mem "subtype" Jsont.string ~enc:subtype
501 |> Jsont.Object.mem "duration_ms" Jsont.int ~enc:duration_ms
502 |> Jsont.Object.mem "duration_api_ms" Jsont.int ~enc:duration_api_ms
503 |> Jsont.Object.mem "is_error" Jsont.bool ~enc:is_error
504 |> Jsont.Object.mem "num_turns" Jsont.int ~enc:num_turns
505 |> Jsont.Object.mem "session_id" Jsont.string ~enc:session_id
506 |> Jsont.Object.opt_mem "total_cost_usd" Jsont.number ~enc:total_cost_usd
507 |> Jsont.Object.opt_mem "usage" Usage.jsont ~enc:usage
508 |> Jsont.Object.opt_mem "result" Jsont.string ~enc:result
509 |> Jsont.Object.opt_mem "structured_output" Jsont.json ~enc:structured_output
510 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
511 |> Jsont.Object.finish
512
513 let to_json t =
514 let fields = [
515 (Jsont.Json.name "type", Jsont.String ("result", Jsont.Meta.none));
516 (Jsont.Json.name "subtype", Jsont.String (t.subtype, Jsont.Meta.none));
517 (Jsont.Json.name "duration_ms", Jsont.Number (float_of_int t.duration_ms, Jsont.Meta.none));
518 (Jsont.Json.name "duration_api_ms", Jsont.Number (float_of_int t.duration_api_ms, Jsont.Meta.none));
519 (Jsont.Json.name "is_error", Jsont.Bool (t.is_error, Jsont.Meta.none));
520 (Jsont.Json.name "num_turns", Jsont.Number (float_of_int t.num_turns, Jsont.Meta.none));
521 (Jsont.Json.name "session_id", Jsont.String (t.session_id, Jsont.Meta.none));
522 ] in
523 let fields = match t.total_cost_usd with
524 | Some cost -> (Jsont.Json.name "total_cost_usd", Jsont.Number (cost, Jsont.Meta.none)) :: fields
525 | None -> fields
526 in
527 let fields = match t.usage with
528 | Some usage -> (Jsont.Json.name "usage", Usage.to_json usage) :: fields
529 | None -> fields
530 in
531 let fields = match t.result with
532 | Some result -> (Jsont.Json.name "result", Jsont.String (result, Jsont.Meta.none)) :: fields
533 | None -> fields
534 in
535 let fields = match t.structured_output with
536 | Some output -> (Jsont.Json.name "structured_output", output) :: fields
537 | None -> fields
538 in
539 Jsont.Object (fields, Jsont.Meta.none)
540
541 let of_json json =
542 match Jsont.Json.decode jsont json with
543 | Ok v -> v
544 | Error msg -> raise (Invalid_argument ("Result.of_json: " ^ msg))
545
546 let pp fmt t =
547 if t.is_error then
548 Fmt.pf fmt "@[<2>Result.error@ { session = %S;@ result = %a }@]"
549 t.session_id
550 Fmt.(option string) t.result
551 else
552 let tokens_info = match t.usage with
553 | Some u ->
554 let input = Usage.input_tokens u in
555 let output = Usage.output_tokens u in
556 let cached = Usage.cache_read_input_tokens u in
557 (match input, output, cached with
558 | Some i, Some o, Some c when c > 0 ->
559 Printf.sprintf " (tokens: %d+%d, cached: %d)" i o c
560 | Some i, Some o, _ ->
561 Printf.sprintf " (tokens: %d+%d)" i o
562 | _ -> "")
563 | None -> ""
564 in
565 Fmt.pf fmt "@[<2>Result.%s@ { duration = %dms;@ cost = $%.4f%s }@]"
566 t.subtype
567 t.duration_ms
568 (Option.value t.total_cost_usd ~default:0.0)
569 tokens_info
570end
571
572type t =
573 | User of User.t
574 | Assistant of Assistant.t
575 | System of System.t
576 | Result of Result.t
577
578let user_string s = User (User.create_string s)
579let user_blocks blocks = User (User.create_blocks blocks)
580let user_with_tool_result ~tool_use_id ~content ?is_error () =
581 User (User.create_with_tool_result ~tool_use_id ~content ?is_error ())
582
583let assistant ~content ~model ?error () = Assistant (Assistant.create ~content ~model ?error ())
584let assistant_text ~text ~model ?error () =
585 Assistant (Assistant.create ~content:[Content_block.text text] ~model ?error ())
586
587let system_init ~session_id =
588 System (System.init ~session_id ())
589let system_error ~error =
590 System (System.error ~error)
591
592let result ~subtype ~duration_ms ~duration_api_ms ~is_error ~num_turns
593 ~session_id ?total_cost_usd ?usage ?result ?structured_output () =
594 Result (Result.create ~subtype ~duration_ms ~duration_api_ms ~is_error
595 ~num_turns ~session_id ?total_cost_usd ?usage ?result ?structured_output ())
596
597let to_json = function
598 | User t -> User.to_json t
599 | Assistant t -> Assistant.to_json t
600 | System t -> System.to_json t
601 | Result t -> Result.to_json t
602
603(* Jsont codec for the main Message variant type.
604 Uses case_mem for discriminated union based on "type" field. *)
605let jsont : t Jsont.t =
606 let case_map kind obj dec = Jsont.Object.Case.map kind obj ~dec in
607 let case_user = case_map "user" User.incoming_jsont (fun v -> User v) in
608 let case_assistant = case_map "assistant" Assistant.incoming_jsont (fun v -> Assistant v) in
609 let case_system = case_map "system" System.jsont (fun v -> System v) in
610 let case_result = case_map "result" Result.jsont (fun v -> Result v) in
611 let enc_case = function
612 | User v -> Jsont.Object.Case.value case_user v
613 | Assistant v -> Jsont.Object.Case.value case_assistant v
614 | System v -> Jsont.Object.Case.value case_system v
615 | Result v -> Jsont.Object.Case.value case_result v
616 in
617 let cases = Jsont.Object.Case.[
618 make case_user;
619 make case_assistant;
620 make case_system;
621 make case_result
622 ] in
623 Jsont.Object.map ~kind:"Message" Fun.id
624 |> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
625 ~tag_to_string:Fun.id ~tag_compare:String.compare
626 |> Jsont.Object.finish
627
628let of_json json =
629 match Jsont.Json.decode jsont json with
630 | Ok v -> v
631 | Error msg -> raise (Invalid_argument ("Message.of_json: " ^ msg))
632
633let pp fmt = function
634 | User t -> User.pp fmt t
635 | Assistant t -> Assistant.pp fmt t
636 | System t -> System.pp fmt t
637 | Result t -> Result.pp fmt t
638
639let is_user = function User _ -> true | _ -> false
640let is_assistant = function Assistant _ -> true | _ -> false
641let is_system = function System _ -> true | _ -> false
642let is_result = function Result _ -> true | _ -> false
643
644let is_error = function
645 | Result r -> Result.is_error r
646 | System s -> System.subtype s = "error"
647 | _ -> false
648
649let extract_text = function
650 | User u -> User.as_text u
651 | Assistant a ->
652 let text = Assistant.combined_text a in
653 if text = "" then None else Some text
654 | _ -> None
655
656let extract_tool_uses = function
657 | Assistant a -> Assistant.get_tool_uses a
658 | _ -> []
659
660let get_session_id = function
661 | System s -> System.session_id s
662 | Result r -> Some (Result.session_id r)
663 | _ -> None
664
665let log_received t =
666 Log.info (fun m -> m "← %a" pp t)
667
668let log_sending t =
669 Log.info (fun m -> m "→ %a" pp t)
670
671let log_error msg t =
672 Log.err (fun m -> m "%s: %a" msg pp t)
673