My agentic slop goes here. Not intended for anyone else!
anil.recoil.org
1let src = Logs.Src.create "claude.content_block" ~doc:"Claude content blocks"
2module Log = (val Logs.src_log src : Logs.LOG)
3
4
5module Text = struct
6 type t = {
7 text : string;
8 unknown : Unknown.t;
9 }
10
11 let create text = { text; unknown = Unknown.empty }
12
13 let make text unknown = { text; unknown }
14 let text t = t.text
15 let unknown t = t.unknown
16
17 let jsont : t Jsont.t =
18 Jsont.Object.map ~kind:"Text" make
19 |> Jsont.Object.mem "text" Jsont.string ~enc:text
20 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
21 |> Jsont.Object.finish
22
23 let to_json t =
24 match Jsont.Json.encode jsont t with
25 | Ok json -> json
26 | Error msg -> failwith ("Text.to_json: " ^ msg)
27
28 let of_json json =
29 match Jsont.Json.decode jsont json with
30 | Ok v -> v
31 | Error msg -> raise (Invalid_argument ("Text.of_json: " ^ msg))
32
33 let pp fmt t =
34 if String.length t.text > 60 then
35 let truncated = String.sub t.text 0 57 in
36 Fmt.pf fmt "Text[%s...]" truncated
37 else
38 Fmt.pf fmt "Text[%S]" t.text
39end
40
41module Tool_use = struct
42 module Input = struct
43 (* Dynamic JSON data for tool inputs with typed accessors using jsont decoders *)
44 type t = Jsont.json
45
46 let jsont = Jsont.json
47
48 let of_string_pairs pairs =
49 Jsont.Json.object' (List.map (fun (k, v) ->
50 Jsont.Json.mem (Jsont.Json.name k) (Jsont.Json.string v)
51 ) pairs)
52
53 let of_assoc (assoc : (string * Jsont.json) list) : t =
54 Jsont.Json.object' (List.map (fun (k, v) -> Jsont.Json.mem (Jsont.Json.name k) v) assoc)
55
56 (* Helper to decode an optional field with a given codec *)
57 let get_opt (type a) (codec : a Jsont.t) t key : a option =
58 let field_codec = Jsont.Object.map ~kind:"field" (fun v -> v)
59 |> Jsont.Object.opt_mem key codec ~enc:Fun.id
60 |> Jsont.Object.finish
61 in
62 match Jsont.Json.decode field_codec t with
63 | Ok v -> v
64 | Error _ -> None
65
66 let get_string t key = get_opt Jsont.string t key
67 let get_int t key = get_opt Jsont.int t key
68 let get_bool t key = get_opt Jsont.bool t key
69 let get_float t key = get_opt Jsont.number t key
70
71 let keys t =
72 (* Decode as object with all members captured as unknown *)
73 match t with
74 | Jsont.Object (members, _) -> List.map (fun ((name, _), _) -> name) members
75 | _ -> []
76
77 let to_json t = t
78 let of_json json = json
79 end
80
81 type t = {
82 id : string;
83 name : string;
84 input : Input.t;
85 unknown : Unknown.t;
86 }
87
88 let create ~id ~name ~input = { id; name; input; unknown = Unknown.empty }
89
90 let make id name input unknown = { id; name; input; unknown }
91 let id t = t.id
92 let name t = t.name
93 let input t = t.input
94 let unknown t = t.unknown
95
96 let jsont : t Jsont.t =
97 Jsont.Object.map ~kind:"Tool_use" make
98 |> Jsont.Object.mem "id" Jsont.string ~enc:id
99 |> Jsont.Object.mem "name" Jsont.string ~enc:name
100 |> Jsont.Object.mem "input" Input.jsont ~enc:input
101 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
102 |> Jsont.Object.finish
103
104 let to_json t =
105 match Jsont.Json.encode jsont t with
106 | Ok json -> json
107 | Error msg -> failwith ("Tool_use.to_json: " ^ msg)
108
109 let of_json json =
110 match Jsont.Json.decode jsont json with
111 | Ok v -> v
112 | Error msg -> raise (Invalid_argument ("Tool_use.of_json: " ^ msg))
113
114 let pp fmt t =
115 let keys = Input.keys t.input in
116 let key_info = match keys with
117 | [] -> ""
118 | [k] -> Printf.sprintf "(%s)" k
119 | ks -> Printf.sprintf "(%d params)" (List.length ks)
120 in
121 Fmt.pf fmt "Tool[%s%s]" t.name key_info
122end
123
124module Tool_result = struct
125 type t = {
126 tool_use_id : string;
127 content : string option;
128 is_error : bool option;
129 unknown : Unknown.t;
130 }
131
132 let create ~tool_use_id ?content ?is_error () =
133 { tool_use_id; content; is_error; unknown = Unknown.empty }
134
135 let make tool_use_id content is_error unknown =
136 { tool_use_id; content; is_error; unknown }
137 let tool_use_id t = t.tool_use_id
138 let content t = t.content
139 let is_error t = t.is_error
140 let unknown t = t.unknown
141
142 let jsont : t Jsont.t =
143 Jsont.Object.map ~kind:"Tool_result" make
144 |> Jsont.Object.mem "tool_use_id" Jsont.string ~enc:tool_use_id
145 |> Jsont.Object.opt_mem "content" Jsont.string ~enc:content
146 |> Jsont.Object.opt_mem "is_error" Jsont.bool ~enc:is_error
147 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
148 |> Jsont.Object.finish
149
150 let to_json t =
151 match Jsont.Json.encode jsont t with
152 | Ok json -> json
153 | Error msg -> failwith ("Tool_result.to_json: " ^ msg)
154
155 let of_json json =
156 match Jsont.Json.decode jsont json with
157 | Ok v -> v
158 | Error msg -> raise (Invalid_argument ("Tool_result.of_json: " ^ msg))
159
160 let pp fmt t =
161 match t.is_error, t.content with
162 | Some true, Some c ->
163 if String.length c > 40 then
164 let truncated = String.sub c 0 37 in
165 Fmt.pf fmt "ToolResult[error: %s...]" truncated
166 else
167 Fmt.pf fmt "ToolResult[error: %s]" c
168 | _, Some c ->
169 if String.length c > 40 then
170 let truncated = String.sub c 0 37 in
171 Fmt.pf fmt "ToolResult[%s...]" truncated
172 else
173 Fmt.pf fmt "ToolResult[%s]" c
174 | _, None -> Fmt.pf fmt "ToolResult[empty]"
175end
176
177module Thinking = struct
178 type t = {
179 thinking : string;
180 signature : string;
181 unknown : Unknown.t;
182 }
183
184 let create ~thinking ~signature = { thinking; signature; unknown = Unknown.empty }
185
186 let make thinking signature unknown = { thinking; signature; unknown }
187 let thinking t = t.thinking
188 let signature t = t.signature
189 let unknown t = t.unknown
190
191 let jsont : t Jsont.t =
192 Jsont.Object.map ~kind:"Thinking" make
193 |> Jsont.Object.mem "thinking" Jsont.string ~enc:thinking
194 |> Jsont.Object.mem "signature" Jsont.string ~enc:signature
195 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
196 |> Jsont.Object.finish
197
198 let to_json t =
199 match Jsont.Json.encode jsont t with
200 | Ok json -> json
201 | Error msg -> failwith ("Thinking.to_json: " ^ msg)
202
203 let of_json json =
204 match Jsont.Json.decode jsont json with
205 | Ok v -> v
206 | Error msg -> raise (Invalid_argument ("Thinking.of_json: " ^ msg))
207
208 let pp fmt t =
209 if String.length t.thinking > 50 then
210 let truncated = String.sub t.thinking 0 47 in
211 Fmt.pf fmt "Thinking[%s...]" truncated
212 else
213 Fmt.pf fmt "Thinking[%s]" t.thinking
214end
215
216type t =
217 | Text of Text.t
218 | Tool_use of Tool_use.t
219 | Tool_result of Tool_result.t
220 | Thinking of Thinking.t
221
222let text s = Text (Text.create s)
223let tool_use ~id ~name ~input = Tool_use (Tool_use.create ~id ~name ~input)
224let tool_result ~tool_use_id ?content ?is_error () =
225 Tool_result (Tool_result.create ~tool_use_id ?content ?is_error ())
226let thinking ~thinking ~signature =
227 Thinking (Thinking.create ~thinking ~signature)
228
229let jsont : t Jsont.t =
230 let case_map kind obj dec = Jsont.Object.Case.map kind obj ~dec in
231
232 let case_text = case_map "text" Text.jsont (fun v -> Text v) in
233 let case_tool_use = case_map "tool_use" Tool_use.jsont (fun v -> Tool_use v) in
234 let case_tool_result = case_map "tool_result" Tool_result.jsont (fun v -> Tool_result v) in
235 let case_thinking = case_map "thinking" Thinking.jsont (fun v -> Thinking v) in
236
237 let enc_case = function
238 | Text v -> Jsont.Object.Case.value case_text v
239 | Tool_use v -> Jsont.Object.Case.value case_tool_use v
240 | Tool_result v -> Jsont.Object.Case.value case_tool_result v
241 | Thinking v -> Jsont.Object.Case.value case_thinking v
242 in
243
244 let cases = Jsont.Object.Case.[
245 make case_text;
246 make case_tool_use;
247 make case_tool_result;
248 make case_thinking
249 ] in
250
251 Jsont.Object.map ~kind:"Content_block" Fun.id
252 |> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
253 ~tag_to_string:Fun.id ~tag_compare:String.compare
254 |> Jsont.Object.finish
255
256let to_json t =
257 match Jsont.Json.encode jsont t with
258 | Ok json -> json
259 | Error msg -> failwith ("Content_block.to_json: " ^ msg)
260
261let of_json json =
262 match Jsont.Json.decode jsont json with
263 | Ok v -> v
264 | Error msg -> raise (Invalid_argument ("Content_block.of_json: " ^ msg))
265
266let pp fmt = function
267 | Text t -> Text.pp fmt t
268 | Tool_use t -> Tool_use.pp fmt t
269 | Tool_result t -> Tool_result.pp fmt t
270 | Thinking t -> Thinking.pp fmt t
271
272let log_received t =
273 Log.debug (fun m -> m "Received content block: %a" pp t)
274
275let log_sending t =
276 Log.debug (fun m -> m "Sending content block: %a" pp t)