gazagnaire.org / ocaml-xmlt
Minimal dependency-free XML parser and serializer
0
fork

Configure Feed

Select the types of activity you want to include in your feed.

Redesign xmlt codec as GADT (jsont soup paper architecture)

Replace closure-based codec with GADT: Text | Text_map | Element |
El | Raw | Map | Const | Option | Rec | List. decode/encode are
generic interpreters. El builder uses Dict + Type.Id.

150 tests + 10 XTCE pass. Public API unchanged.

Thomas Gazagnaire 532de49f fb5a8a99

+773 -453
+609 -453
lib/xmlt.ml
··· 878 878 in 879 879 loop [] 880 880 881 - (* ── Codec types ────────────────────────────────────────────────────── *) 881 + (* ── Heterogeneous dictionary using Type.Id ────────────────────────── *) 882 882 883 - (* The codec has two decode paths: 884 - - dec_tree: decodes from a Tree.element (used by Tree escape hatch 885 - and by El children that have already been parsed) 886 - - dec_stream: decodes directly from a P.stream. The stream is 887 - positioned inside an element (after '>' or at '/>'), with tag 888 - and attrs already extracted. For self-closing elements, 889 - self_close=true and there is nothing to consume. 883 + module Dict : sig 884 + type t 890 885 891 - The encode path writes directly to an encoder (unchanged). *) 886 + val empty : t 887 + val add : 'a Type.Id.t -> 'a -> t -> t 888 + val find : 'a Type.Id.t -> t -> 'a option 889 + end = struct 890 + module M = Map.Make (Int) 892 891 893 - type 'a t = { 894 - dec_tree : Tree.element -> ('a, string) result; 895 - dec_stream : 896 - P.stream -> 897 - tag:string -> 898 - attrs:(string * string) list -> 899 - self_close:bool -> 900 - ('a, string) result; 901 - enc : encoder -> 'a -> unit; 902 - } 892 + type binding = B : 'a Type.Id.t * 'a -> binding 893 + type t = binding M.t 903 894 904 - (* ── Base type codecs ───────────────────────────────────────────────── *) 895 + let empty = M.empty 896 + let uid id = Type.Id.uid id 905 897 906 - (* For base codecs, dec_stream reads text content directly from the stream 907 - without building Tree nodes. *) 898 + let add (type a) (id : a Type.Id.t) (v : a) (d : t) : t = 899 + M.add (uid id) (B (id, v)) d 908 900 909 - let make_base_codec ~parse ~enc_fn = 910 - { 911 - dec_tree = 912 - (fun el -> 913 - let s = String.trim (Tree.text el) in 914 - parse s); 915 - dec_stream = 916 - (fun s ~tag:_ ~attrs:_ ~self_close -> 917 - if self_close then parse "" 918 - else 919 - match stream_read_text s with 920 - | Error e -> Error e 921 - | Ok text -> parse (String.trim text)); 922 - enc = enc_fn; 923 - } 924 - 925 - let string = 926 - { 927 - dec_tree = (fun el -> Ok (Tree.text el)); 928 - dec_stream = 929 - (fun s ~tag:_ ~attrs:_ ~self_close -> 930 - if self_close then Ok "" else stream_read_text s); 931 - enc = (fun e s -> enc_text e s); 932 - } 933 - 934 - let int = 935 - make_base_codec 936 - ~parse:(fun s -> 937 - match int_of_string_opt s with 938 - | Some n -> Ok n 939 - | None -> Error (Printf.sprintf "expected integer, got %S" s)) 940 - ~enc_fn:(fun e n -> enc_text e (string_of_int n)) 941 - 942 - let float = 943 - make_base_codec 944 - ~parse:(fun s -> 945 - match float_of_string_opt s with 946 - | Some f -> Ok f 947 - | None -> Error (Printf.sprintf "expected float, got %S" s)) 948 - ~enc_fn:(fun e f -> enc_text e (string_of_float f)) 949 - 950 - let bool = 951 - make_base_codec 952 - ~parse:(fun s -> 953 - match String.lowercase_ascii s with 954 - | "true" -> Ok true 955 - | "false" -> Ok false 956 - | _ -> Error (Printf.sprintf "expected boolean, got %S" s)) 957 - ~enc_fn:(fun e b -> enc_text e (string_of_bool b)) 958 - 959 - (* ── Element wrapper ────────────────────────────────────────────────── *) 960 - 961 - (* element wraps the inner codec in a named element. On streaming decode: 962 - 1. The outer element's dec_stream is called with the element's tag/attrs 963 - 2. It checks the tag matches 964 - 3. It delegates to the inner codec's dec_stream 965 - 4. It consumes the end tag *) 966 - 967 - let element tag codec = 968 - { 969 - dec_tree = 970 - (fun el -> 971 - if el.tag <> tag then 972 - Error 973 - (Printf.sprintf "expected element <%s>, got <%s>" tag el.Tree.tag) 974 - else codec.dec_tree el); 975 - dec_stream = 976 - (fun s ~tag:actual_tag ~attrs ~self_close -> 977 - if actual_tag <> tag then 978 - Error 979 - (Printf.sprintf "expected element <%s>, got <%s>" tag actual_tag) 980 - else 981 - let result = codec.dec_stream s ~tag ~attrs ~self_close in 982 - if self_close then result 983 - else 984 - match result with 985 - | Error e -> Error e 986 - | Ok v -> ( 987 - match P.consume_end_tag s tag with 988 - | Error e -> Error e 989 - | Ok () -> Ok v)); 990 - enc = 991 - (fun e v -> 992 - enc_start_tag e tag; 993 - codec.enc e v; 994 - if e.in_start_tag then 995 - (* No children/text were written; self-close *) 996 - enc_end_tag_empty e 997 - else enc_end_tag e tag ~has_elements:false); 998 - } 901 + let find (type a) (id : a Type.Id.t) (d : t) : a option = 902 + match M.find_opt (uid id) d with 903 + | None -> None 904 + | Some (B (id', v)) -> ( 905 + match Type.Id.provably_equal id id' with 906 + | Some Type.Equal -> Some v 907 + | None -> None) 908 + end 999 909 1000 - (* ── Attribute codecs ───────────────────────────────────────────────── *) 910 + (* ── GADT codec type ───────────────────────────────────────────────── *) 1001 911 1002 912 module Attr = struct 1003 913 type 'a codec = { dec : string -> ('a, string) result; enc : 'a -> string } ··· 1049 959 } 1050 960 end 1051 961 1052 - (* ── Element builder ────────────────────────────────────────────────── *) 962 + (* The GADT codec type. Each constructor is inspectable data that can be 963 + pattern-matched by decode, encode, or any future interpreter (schema 964 + generation, etc.). This is the "finally tagged" approach. *) 965 + 966 + type ('a, 'b) base_map = { 967 + base_kind : string; 968 + base_dec : string -> ('b, string) result; 969 + base_enc : 'b -> string; 970 + } 971 + 972 + type ('a, 'b) map_with = { 973 + dom : 'a t; 974 + map_dec : 'a -> ('b, string) result; 975 + map_enc : 'b -> 'a; 976 + } 977 + 978 + and ('ret, 'f) dec_fun = 979 + | Dec_fun : 'f -> ('ret, 'f) dec_fun 980 + | Dec_app : ('ret, 'a -> 'b) dec_fun * 'a Type.Id.t -> ('ret, 'b) dec_fun 981 + 982 + and _ t = 983 + | Text : string t 984 + | Text_map : (string, 'b) base_map -> 'b t 985 + | Element : string * 'a t -> 'a t 986 + | El : string * ('o, 'o) el_map -> 'o t 987 + | Raw : Tree.element t 988 + | Map : ('a, 'b) map_with -> 'b t 989 + | Const : 'a -> 'a t 990 + | Option : 'a t -> 'a option t 991 + | Rec : 'a t Lazy.t -> 'a t 992 + | List : 'a t -> 'a list t 993 + 994 + and ('o, 'dec) el_map = { 995 + el_dec : ('o, 'dec) dec_fun; 996 + el_fields : 'o el_field list; 997 + el_needs_children : bool; 998 + } 999 + 1000 + and 'o el_field = 1001 + | Attr : string * 'a Attr.codec * 'a Type.Id.t * ('o -> 'a) -> 'o el_field 1002 + | Attr_opt : 1003 + string * 'a Attr.codec * 'a option Type.Id.t * ('o -> 'a option) 1004 + -> 'o el_field 1005 + | Child : string * 'a t * 'a Type.Id.t * ('o -> 'a) -> 'o el_field 1006 + | Child_opt : 1007 + string * 'a t * 'a option Type.Id.t * ('o -> 'a option) 1008 + -> 'o el_field 1009 + | Children : 1010 + string * 'a t * 'a list Type.Id.t * ('o -> 'a list) 1011 + -> 'o el_field 1012 + | El_text : string Type.Id.t * ('o -> string) -> 'o el_field 1013 + 1014 + (* ── GADT decode interpreter ───────────────────────────────────────── *) 1015 + 1016 + let rec apply_dec_fun : type ret f. (ret, f) dec_fun -> Dict.t -> f = 1017 + fun df dict -> 1018 + match df with 1019 + | Dec_fun f -> f 1020 + | Dec_app (rest, id) -> 1021 + let f = apply_dec_fun rest dict in 1022 + let v = 1023 + match Dict.find id dict with 1024 + | Some v -> v 1025 + | None -> failwith "internal: field not found in dict" 1026 + in 1027 + f v 1028 + 1029 + (* -- Tree decode -- *) 1030 + 1031 + let rec dec_tree : type a. a t -> Tree.element -> (a, string) result = 1032 + fun c el -> 1033 + match c with 1034 + | Text -> Ok (Tree.text el) 1035 + | Text_map m -> 1036 + let s = String.trim (Tree.text el) in 1037 + m.base_dec s 1038 + | Element (tag, inner) -> 1039 + if el.Tree.tag <> tag then 1040 + Error (Printf.sprintf "expected element <%s>, got <%s>" tag el.Tree.tag) 1041 + else dec_tree inner el 1042 + | El (tag, map) -> 1043 + if tag <> "" && el.Tree.tag <> tag then 1044 + Error (Printf.sprintf "expected element <%s>, got <%s>" tag el.Tree.tag) 1045 + else dec_tree_el map el 1046 + | Raw -> Ok el 1047 + | Map mw -> ( 1048 + match dec_tree mw.dom el with Error e -> Error e | Ok a -> mw.map_dec a) 1049 + | Const v -> Ok v 1050 + | Option inner -> ( 1051 + match dec_tree inner el with Ok v -> Ok (Some v) | Error _ -> Ok None) 1052 + | Rec lz -> dec_tree (Lazy.force lz) el 1053 + | List inner -> 1054 + let child_els = 1055 + List.filter_map 1056 + (function Tree.Element e -> Some e | Tree.Text _ -> None) 1057 + el.children 1058 + in 1059 + dec_tree_list inner child_els 1060 + 1061 + and dec_tree_list : type a. a t -> Tree.element list -> (a list, string) result 1062 + = 1063 + fun inner els -> 1064 + let rec loop acc = function 1065 + | [] -> Ok (List.rev acc) 1066 + | el :: rest -> ( 1067 + match dec_tree inner el with 1068 + | Ok v -> loop (v :: acc) rest 1069 + | Error e -> Error e) 1070 + in 1071 + loop [] els 1072 + 1073 + and dec_tree_el : type o. (o, o) el_map -> Tree.element -> (o, string) result = 1074 + fun map el -> 1075 + let children = 1076 + List.filter_map 1077 + (function Tree.Element e -> Some e | Tree.Text _ -> None) 1078 + el.Tree.children 1079 + in 1080 + let text = Tree.text el in 1081 + dec_el_fields map.el_fields el.Tree.attrs children text Dict.empty 1082 + |> Result.map (fun dict -> apply_dec_fun map.el_dec dict) 1083 + 1084 + and dec_el_fields : type o. 1085 + o el_field list -> 1086 + (string * string) list -> 1087 + Tree.element list -> 1088 + string -> 1089 + Dict.t -> 1090 + (Dict.t, string) result = 1091 + fun fields attrs children text dict -> 1092 + match fields with 1093 + | [] -> Ok dict 1094 + | field :: rest -> ( 1095 + match dec_el_field field attrs children text dict with 1096 + | Error e -> Error e 1097 + | Ok dict' -> dec_el_fields rest attrs children text dict') 1098 + 1099 + and dec_el_field : type o. 1100 + o el_field -> 1101 + (string * string) list -> 1102 + Tree.element list -> 1103 + string -> 1104 + Dict.t -> 1105 + (Dict.t, string) result = 1106 + fun field attrs children text dict -> 1107 + match field with 1108 + | Attr (name, codec, id, _enc) -> ( 1109 + match List.assoc_opt name attrs with 1110 + | None -> 1111 + Error (Printf.sprintf "missing required attribute %S on element" name) 1112 + | Some s -> ( 1113 + match codec.dec s with 1114 + | Ok v -> Ok (Dict.add id v dict) 1115 + | Error e -> Error e)) 1116 + | Attr_opt (name, codec, id, _enc) -> ( 1117 + match List.assoc_opt name attrs with 1118 + | None -> Ok (Dict.add id None dict) 1119 + | Some s -> ( 1120 + match codec.dec s with 1121 + | Ok v -> Ok (Dict.add id (Some v) dict) 1122 + | Error e -> Error e)) 1123 + | Child (tag, inner, id, _enc) -> ( 1124 + let child_el = 1125 + let rec loop = function 1126 + | [] -> None 1127 + | el :: _ when el.Tree.tag = tag -> Some el 1128 + | _ :: rest -> loop rest 1129 + in 1130 + loop children 1131 + in 1132 + match child_el with 1133 + | None -> Error (Printf.sprintf "missing required child element <%s>" tag) 1134 + | Some el -> ( 1135 + match dec_tree inner el with 1136 + | Ok v -> Ok (Dict.add id v dict) 1137 + | Error e -> Error e)) 1138 + | Child_opt (tag, inner, id, _enc) -> ( 1139 + let child_el = 1140 + let rec loop = function 1141 + | [] -> None 1142 + | el :: _ when el.Tree.tag = tag -> Some el 1143 + | _ :: rest -> loop rest 1144 + in 1145 + loop children 1146 + in 1147 + match child_el with 1148 + | None -> Ok (Dict.add id None dict) 1149 + | Some el -> ( 1150 + match dec_tree inner el with 1151 + | Ok v -> Ok (Dict.add id (Some v) dict) 1152 + | Error e -> Error e)) 1153 + | Children (tag, inner, id, _enc) -> 1154 + let child_els = List.filter (fun el -> el.Tree.tag = tag) children in 1155 + let rec decode_all acc = function 1156 + | [] -> Ok (Dict.add id (List.rev acc) dict) 1157 + | el :: rest -> ( 1158 + match dec_tree inner el with 1159 + | Ok v -> decode_all (v :: acc) rest 1160 + | Error e -> Error e) 1161 + in 1162 + decode_all [] child_els 1163 + | El_text (id, _enc) -> Ok (Dict.add id text dict) 1164 + 1165 + (* -- Stream decode -- *) 1166 + 1167 + let rec dec_stream : type a. 1168 + a t -> 1169 + P.stream -> 1170 + tag:string -> 1171 + attrs:(string * string) list -> 1172 + self_close:bool -> 1173 + (a, string) result = 1174 + fun c s ~tag ~attrs ~self_close -> 1175 + match c with 1176 + | Text -> if self_close then Ok "" else stream_read_text s 1177 + | Text_map m -> ( 1178 + if self_close then m.base_dec "" 1179 + else 1180 + match stream_read_text s with 1181 + | Error e -> Error e 1182 + | Ok text -> m.base_dec (String.trim text)) 1183 + | Element (el_tag, inner) -> ( 1184 + if tag <> el_tag then 1185 + Error (Printf.sprintf "expected element <%s>, got <%s>" el_tag tag) 1186 + else 1187 + let result = dec_stream inner s ~tag ~attrs ~self_close in 1188 + if self_close then result 1189 + else 1190 + match result with 1191 + | Error e -> Error e 1192 + | Ok v -> ( 1193 + match P.consume_end_tag s tag with 1194 + | Error e -> Error e 1195 + | Ok () -> Ok v)) 1196 + | El (el_tag, map) -> ( 1197 + if el_tag <> "" && tag <> el_tag then 1198 + Error (Printf.sprintf "expected element <%s>, got <%s>" el_tag tag) 1199 + else 1200 + let result = dec_stream_el map s ~attrs ~self_close in 1201 + if self_close then result 1202 + else 1203 + match result with 1204 + | Error e -> Error e 1205 + | Ok v -> ( 1206 + match P.consume_end_tag s tag with 1207 + | Error e -> Error e 1208 + | Ok () -> Ok v)) 1209 + | Raw -> ( 1210 + if 1211 + (* Build a full Tree.element from the stream *) 1212 + self_close 1213 + then Ok { Tree.tag; attrs; children = [] } 1214 + else 1215 + match stream_parse_children s with 1216 + | Error e -> Error e 1217 + | Ok children -> ( 1218 + match P.consume_end_tag s tag with 1219 + | Error e -> Error e 1220 + | Ok () -> Ok { Tree.tag; attrs; children })) 1221 + | Map mw -> ( 1222 + match dec_stream mw.dom s ~tag ~attrs ~self_close with 1223 + | Error e -> Error e 1224 + | Ok a -> mw.map_dec a) 1225 + | Const v -> Ok v 1226 + | Option inner -> ( 1227 + match dec_stream inner s ~tag ~attrs ~self_close with 1228 + | Ok v -> Ok (Some v) 1229 + | Error _ -> Ok None) 1230 + | Rec lz -> dec_stream (Lazy.force lz) s ~tag ~attrs ~self_close 1231 + | List inner -> ( 1232 + if self_close then Ok [] 1233 + else 1234 + match stream_collect_children s with 1235 + | Error e -> Error e 1236 + | Ok (children, _text) -> dec_tree_list inner children) 1053 1237 1054 - module El = struct 1055 - (* The builder accumulates decode/encode steps. For decode, it supports 1056 - two paths: 1057 - - decode_tree: from a Tree.element (for already-parsed elements) 1058 - - decode_stream: from a P.stream with parsed attrs and collected 1059 - children (for the streaming codec path) 1238 + and dec_stream_el : type o. 1239 + (o, o) el_map -> 1240 + P.stream -> 1241 + attrs:(string * string) list -> 1242 + self_close:bool -> 1243 + (o, string) result = 1244 + fun map s ~attrs ~self_close -> 1245 + if self_close then 1246 + dec_el_fields map.el_fields attrs [] "" Dict.empty 1247 + |> Result.map (fun dict -> apply_dec_fun map.el_dec dict) 1248 + else if map.el_needs_children then 1249 + match stream_collect_children s with 1250 + | Error e -> Error e 1251 + | Ok (children, text) -> 1252 + dec_el_fields map.el_fields attrs children text Dict.empty 1253 + |> Result.map (fun dict -> apply_dec_fun map.el_dec dict) 1254 + else 1255 + match stream_skip_children s with 1256 + | Error e -> Error e 1257 + | Ok () -> 1258 + dec_el_fields map.el_fields attrs [] "" Dict.empty 1259 + |> Result.map (fun dict -> apply_dec_fun map.el_dec dict) 1060 1260 1061 - Both paths thread through a decoder function that builds the final 1062 - value by applying one field at a time. 1261 + (* ── GADT encode interpreter ───────────────────────────────────────── *) 1063 1262 1064 - The encode side splits into two phases: attrs (written while the start 1065 - tag is still open) and children (written after the start tag is closed). 1066 - This ensures attrs always appear before children regardless of builder 1067 - order. *) 1068 - type ('o, 'dec) t = { 1069 - decode_tree : Tree.element -> ('dec, string) result; 1070 - decode_stream : 1071 - attrs:(string * string) list -> 1072 - children:Tree.element list -> 1073 - text:string -> 1074 - ('dec, string) result; 1075 - needs_children : bool; (* true if any child/children/text field *) 1076 - encode_attrs : encoder -> 'o -> unit; 1077 - encode_children : encoder -> 'o -> unit; 1078 - } 1263 + let rec enc_value : type a. a t -> encoder -> a -> unit = 1264 + fun c e v -> 1265 + match c with 1266 + | Text -> enc_text e v 1267 + | Text_map m -> enc_text e (m.base_enc v) 1268 + | Element (tag, inner) -> 1269 + enc_start_tag e tag; 1270 + enc_value inner e v; 1271 + if e.in_start_tag then enc_end_tag_empty e 1272 + else enc_end_tag e tag ~has_elements:false 1273 + | El (tag, map) -> enc_el tag map e v 1274 + | Raw -> Tree.write_to (fun s -> e.w s) v 1275 + | Map mw -> enc_value mw.dom e (mw.map_enc v) 1276 + | Const _ -> () 1277 + | Option inner -> ( match v with Some x -> enc_value inner e x | None -> ()) 1278 + | Rec lz -> enc_value (Lazy.force lz) e v 1279 + | List inner -> 1280 + List.iter 1281 + (fun item -> 1282 + enc_close_start_tag e; 1283 + enc_value inner e item) 1284 + v 1079 1285 1080 - let obj dec = 1286 + and enc_el : type o. string -> (o, o) el_map -> encoder -> o -> unit = 1287 + fun tag map e v -> 1288 + if tag = "" then begin 1289 + (* Bare El from El.finish (no element wrapper) -- just encode 1290 + attrs and children into the current (already open) element *) 1291 + List.iter (fun field -> enc_el_field_attr field e v) map.el_fields; 1292 + List.iter (fun field -> enc_el_field_child field e v) map.el_fields 1293 + end 1294 + else begin 1295 + enc_start_tag e tag; 1296 + (* Phase 1: write all attributes (start tag is still open) *) 1297 + List.iter (fun field -> enc_el_field_attr field e v) map.el_fields; 1298 + (* Phase 2: write all children (will close start tag on first write) *) 1299 + List.iter (fun field -> enc_el_field_child field e v) map.el_fields; 1300 + if e.in_start_tag then enc_end_tag_empty e 1301 + else enc_end_tag e tag ~has_elements:false 1302 + end 1303 + 1304 + and enc_el_field_attr : type o. o el_field -> encoder -> o -> unit = 1305 + fun field e v -> 1306 + match field with 1307 + | Attr (name, codec, _id, enc) -> enc_attr e name (codec.enc (enc v)) 1308 + | Attr_opt (name, codec, _id, enc) -> ( 1309 + match enc v with None -> () | Some a -> enc_attr e name (codec.enc a)) 1310 + | Child _ | Child_opt _ | Children _ | El_text _ -> () 1311 + 1312 + and enc_el_field_child : type o. o el_field -> encoder -> o -> unit = 1313 + fun field e v -> 1314 + match field with 1315 + | Attr _ | Attr_opt _ -> () 1316 + | Child (tag, inner, _id, enc) -> 1317 + enc_close_start_tag e; 1318 + enc_start_tag e tag; 1319 + enc_value inner e (enc v); 1320 + if e.in_start_tag then enc_end_tag_empty e 1321 + else enc_end_tag e tag ~has_elements:false 1322 + | Child_opt (tag, inner, _id, enc) -> ( 1323 + match enc v with 1324 + | None -> () 1325 + | Some child_v -> 1326 + enc_close_start_tag e; 1327 + enc_start_tag e tag; 1328 + enc_value inner e child_v; 1329 + if e.in_start_tag then enc_end_tag_empty e 1330 + else enc_end_tag e tag ~has_elements:false) 1331 + | Children (tag, inner, _id, enc) -> 1332 + List.iter 1333 + (fun child_v -> 1334 + enc_close_start_tag e; 1335 + enc_start_tag e tag; 1336 + enc_value inner e child_v; 1337 + if e.in_start_tag then enc_end_tag_empty e 1338 + else enc_end_tag e tag ~has_elements:false) 1339 + (enc v) 1340 + | El_text (_id, enc) -> 1341 + let s = enc v in 1342 + if String.length s > 0 then begin 1343 + enc_close_start_tag e; 1344 + enc_text e s 1345 + end 1346 + 1347 + (* ── Base type codecs ──────────────────────────────────────────────── *) 1348 + 1349 + let string : string t = Text 1350 + 1351 + let int : int t = 1352 + Text_map 1081 1353 { 1082 - decode_tree = (fun _el -> Ok dec); 1083 - decode_stream = (fun ~attrs:_ ~children:_ ~text:_ -> Ok dec); 1084 - needs_children = false; 1085 - encode_attrs = (fun _e _v -> ()); 1086 - encode_children = (fun _e _v -> ()); 1354 + base_kind = "int"; 1355 + base_dec = 1356 + (fun s -> 1357 + match int_of_string_opt s with 1358 + | Some n -> Ok n 1359 + | None -> Error (Printf.sprintf "expected integer, got %S" s)); 1360 + base_enc = string_of_int; 1087 1361 } 1088 1362 1089 - let attr name (codec : 'a Attr.codec) ~enc builder = 1090 - let decode_attr attrs prev_result = 1091 - match prev_result with 1092 - | Error e -> Error e 1093 - | Ok f -> ( 1094 - match List.assoc_opt name attrs with 1095 - | None -> 1096 - Error 1097 - (Printf.sprintf "missing required attribute %S on element" name) 1098 - | Some s -> ( 1099 - match codec.dec s with Ok v -> Ok (f v) | Error e -> Error e)) 1100 - in 1363 + let float : float t = 1364 + Text_map 1101 1365 { 1102 - decode_tree = 1103 - (fun el -> 1104 - match builder.decode_tree el with 1105 - | Error e -> Error e 1106 - | Ok f -> ( 1107 - match List.assoc_opt name el.Tree.attrs with 1108 - | None -> 1109 - Error 1110 - (Printf.sprintf "missing required attribute %S on <%s>" name 1111 - el.tag) 1112 - | Some s -> ( 1113 - match codec.dec s with Ok v -> Ok (f v) | Error e -> Error e))); 1114 - decode_stream = 1115 - (fun ~attrs ~children ~text -> 1116 - decode_attr attrs (builder.decode_stream ~attrs ~children ~text)); 1117 - needs_children = builder.needs_children; 1118 - encode_attrs = 1119 - (fun e v -> 1120 - builder.encode_attrs e v; 1121 - enc_attr e name (codec.enc (enc v))); 1122 - encode_children = (fun e v -> builder.encode_children e v); 1366 + base_kind = "float"; 1367 + base_dec = 1368 + (fun s -> 1369 + match float_of_string_opt s with 1370 + | Some f -> Ok f 1371 + | None -> Error (Printf.sprintf "expected float, got %S" s)); 1372 + base_enc = string_of_float; 1123 1373 } 1124 1374 1125 - let attr_opt name (codec : _ Attr.codec) ~enc builder = 1126 - let decode_attr_opt attrs prev_result = 1127 - match prev_result with 1128 - | Error e -> Error e 1129 - | Ok f -> ( 1130 - match List.assoc_opt name attrs with 1131 - | None -> Ok (f None) 1132 - | Some s -> ( 1133 - match codec.dec s with 1134 - | Ok v -> Ok (f (Some v)) 1135 - | Error e -> Error e)) 1136 - in 1375 + let bool : bool t = 1376 + Text_map 1137 1377 { 1138 - decode_tree = 1139 - (fun el -> 1140 - match builder.decode_tree el with 1141 - | Error e -> Error e 1142 - | Ok f -> ( 1143 - match List.assoc_opt name el.Tree.attrs with 1144 - | None -> Ok (f None) 1145 - | Some s -> ( 1146 - match codec.dec s with 1147 - | Ok v -> Ok (f (Some v)) 1148 - | Error e -> Error e))); 1149 - decode_stream = 1150 - (fun ~attrs ~children ~text -> 1151 - decode_attr_opt attrs (builder.decode_stream ~attrs ~children ~text)); 1152 - needs_children = builder.needs_children; 1153 - encode_attrs = 1154 - (fun e v -> 1155 - builder.encode_attrs e v; 1156 - match enc v with 1157 - | None -> () 1158 - | Some a -> enc_attr e name (codec.enc a)); 1159 - encode_children = (fun e v -> builder.encode_children e v); 1378 + base_kind = "bool"; 1379 + base_dec = 1380 + (fun s -> 1381 + match String.lowercase_ascii s with 1382 + | "true" -> Ok true 1383 + | "false" -> Ok false 1384 + | _ -> Error (Printf.sprintf "expected boolean, got %S" s)); 1385 + base_enc = string_of_bool; 1160 1386 } 1161 1387 1162 - (* Helper: find first child element by tag in a list *) 1163 - let find_child tag children = 1164 - let rec loop = function 1165 - | [] -> None 1166 - | el :: _ when el.Tree.tag = tag -> Some el 1167 - | _ :: rest -> loop rest 1168 - in 1169 - loop children 1388 + (* ── Element builder ───────────────────────────────────────────────── *) 1170 1389 1171 - (* Helper: find all child elements by tag in a list *) 1172 - let find_all_children tag children = 1173 - List.filter (fun el -> el.Tree.tag = tag) children 1390 + module El = struct 1391 + type 'a codec = 'a t 1174 1392 1175 - let write_child_element e tag codec child_v = 1176 - enc_close_start_tag e; 1177 - enc_start_tag e tag; 1178 - codec.enc e child_v; 1179 - if e.in_start_tag then enc_end_tag_empty e 1180 - else enc_end_tag e tag ~has_elements:false 1393 + type ('o, 'dec) t = { 1394 + dec : ('o, 'dec) dec_fun; 1395 + fields : 'o el_field list; (* in reverse order, reversed at finish *) 1396 + needs_children : bool; 1397 + } 1398 + 1399 + let obj dec = { dec = Dec_fun dec; fields = []; needs_children = false } 1181 1400 1182 - let child tag codec ~enc builder = 1401 + let attr name (codec : 'a Attr.codec) ~enc builder = 1402 + let id = Type.Id.make () in 1183 1403 { 1184 - decode_tree = 1185 - (fun el -> 1186 - match builder.decode_tree el with 1187 - | Error e -> Error e 1188 - | Ok f -> ( 1189 - match Tree.find tag el with 1190 - | None -> 1191 - Error 1192 - (Printf.sprintf 1193 - "missing required child element <%s> in <%s>" tag el.tag) 1194 - | Some child_el -> ( 1195 - match codec.dec_tree child_el with 1196 - | Ok v -> Ok (f v) 1197 - | Error e -> Error e))); 1198 - decode_stream = 1199 - (fun ~attrs ~children ~text -> 1200 - match builder.decode_stream ~attrs ~children ~text with 1201 - | Error e -> Error e 1202 - | Ok f -> ( 1203 - match find_child tag children with 1204 - | None -> 1205 - Error 1206 - (Printf.sprintf "missing required child element <%s>" tag) 1207 - | Some child_el -> ( 1208 - match codec.dec_tree child_el with 1209 - | Ok v -> Ok (f v) 1210 - | Error e -> Error e))); 1404 + dec = Dec_app (builder.dec, id); 1405 + fields = Attr (name, codec, id, enc) :: builder.fields; 1406 + needs_children = builder.needs_children; 1407 + } 1408 + 1409 + let attr_opt name (codec : 'a Attr.codec) ~enc builder = 1410 + let id = Type.Id.make () in 1411 + { 1412 + dec = Dec_app (builder.dec, id); 1413 + fields = Attr_opt (name, codec, id, enc) :: builder.fields; 1414 + needs_children = builder.needs_children; 1415 + } 1416 + 1417 + let child tag (inner : 'a codec) ~enc builder = 1418 + let id = Type.Id.make () in 1419 + { 1420 + dec = Dec_app (builder.dec, id); 1421 + fields = Child (tag, inner, id, enc) :: builder.fields; 1211 1422 needs_children = true; 1212 - encode_attrs = (fun e v -> builder.encode_attrs e v); 1213 - encode_children = 1214 - (fun e v -> 1215 - builder.encode_children e v; 1216 - write_child_element e tag codec (enc v)); 1217 1423 } 1218 1424 1219 - let child_opt tag codec ~enc builder = 1425 + let child_opt tag (inner : 'a codec) ~enc builder = 1426 + let id = Type.Id.make () in 1220 1427 { 1221 - decode_tree = 1222 - (fun el -> 1223 - match builder.decode_tree el with 1224 - | Error e -> Error e 1225 - | Ok f -> ( 1226 - match Tree.find tag el with 1227 - | None -> Ok (f None) 1228 - | Some child_el -> ( 1229 - match codec.dec_tree child_el with 1230 - | Ok v -> Ok (f (Some v)) 1231 - | Error e -> Error e))); 1232 - decode_stream = 1233 - (fun ~attrs ~children ~text -> 1234 - match builder.decode_stream ~attrs ~children ~text with 1235 - | Error e -> Error e 1236 - | Ok f -> ( 1237 - match find_child tag children with 1238 - | None -> Ok (f None) 1239 - | Some child_el -> ( 1240 - match codec.dec_tree child_el with 1241 - | Ok v -> Ok (f (Some v)) 1242 - | Error e -> Error e))); 1428 + dec = Dec_app (builder.dec, id); 1429 + fields = Child_opt (tag, inner, id, enc) :: builder.fields; 1243 1430 needs_children = true; 1244 - encode_attrs = (fun e v -> builder.encode_attrs e v); 1245 - encode_children = 1246 - (fun e v -> 1247 - builder.encode_children e v; 1248 - match enc v with 1249 - | None -> () 1250 - | Some child_v -> write_child_element e tag codec child_v); 1251 1431 } 1252 1432 1253 - let children tag codec ~enc builder = 1433 + let children tag (inner : 'a codec) ~enc builder = 1434 + let id = Type.Id.make () in 1254 1435 { 1255 - decode_tree = 1256 - (fun el -> 1257 - match builder.decode_tree el with 1258 - | Error e -> Error e 1259 - | Ok f -> 1260 - let child_els = Tree.find_all tag el in 1261 - let rec decode_all acc = function 1262 - | [] -> Ok (f (List.rev acc)) 1263 - | child_el :: rest -> ( 1264 - match codec.dec_tree child_el with 1265 - | Ok v -> decode_all (v :: acc) rest 1266 - | Error e -> Error e) 1267 - in 1268 - decode_all [] child_els); 1269 - decode_stream = 1270 - (fun ~attrs ~children:child_list ~text -> 1271 - match builder.decode_stream ~attrs ~children:child_list ~text with 1272 - | Error e -> Error e 1273 - | Ok f -> 1274 - let child_els = find_all_children tag child_list in 1275 - let rec decode_all acc = function 1276 - | [] -> Ok (f (List.rev acc)) 1277 - | child_el :: rest -> ( 1278 - match codec.dec_tree child_el with 1279 - | Ok v -> decode_all (v :: acc) rest 1280 - | Error e -> Error e) 1281 - in 1282 - decode_all [] child_els); 1436 + dec = Dec_app (builder.dec, id); 1437 + fields = Children (tag, inner, id, enc) :: builder.fields; 1283 1438 needs_children = true; 1284 - encode_attrs = (fun e v -> builder.encode_attrs e v); 1285 - encode_children = 1286 - (fun e v -> 1287 - builder.encode_children e v; 1288 - List.iter 1289 - (fun child_v -> write_child_element e tag codec child_v) 1290 - (enc v)); 1291 1439 } 1292 1440 1293 1441 let text ~enc builder = 1442 + let id = Type.Id.make () in 1294 1443 { 1295 - decode_tree = 1296 - (fun el -> 1297 - match builder.decode_tree el with 1298 - | Error e -> Error e 1299 - | Ok f -> Ok (f (Tree.text el))); 1300 - decode_stream = 1301 - (fun ~attrs ~children:_ ~text -> 1302 - match builder.decode_stream ~attrs ~children:[] ~text with 1303 - | Error e -> Error e 1304 - | Ok f -> Ok (f text)); 1444 + dec = Dec_app (builder.dec, id); 1445 + fields = El_text (id, enc) :: builder.fields; 1305 1446 needs_children = true; 1306 - encode_attrs = (fun e v -> builder.encode_attrs e v); 1307 - encode_children = 1308 - (fun e v -> 1309 - builder.encode_children e v; 1310 - let s = enc v in 1311 - if String.length s > 0 then begin 1312 - enc_close_start_tag e; 1313 - enc_text e s 1314 - end); 1315 1447 } 1316 1448 1317 - let finish builder = 1318 - { 1319 - dec_tree = builder.decode_tree; 1320 - dec_stream = 1321 - (fun s ~tag:_ ~attrs ~self_close -> 1322 - if self_close then 1323 - (* Self-closing element: no children, no text *) 1324 - builder.decode_stream ~attrs ~children:[] ~text:"" 1325 - else if builder.needs_children then 1326 - (* Builder has child/text fields: collect children from stream *) 1327 - match stream_collect_children s with 1328 - | Error e -> Error e 1329 - | Ok (children, text) -> 1330 - builder.decode_stream ~attrs ~children ~text 1331 - else 1332 - (* Builder only has attr fields: skip children entirely *) 1333 - match stream_skip_children s with 1334 - | Error e -> Error e 1335 - | Ok () -> builder.decode_stream ~attrs ~children:[] ~text:""); 1336 - enc = 1337 - (fun e v -> 1338 - (* Phase 1: write all attributes (start tag is still open) *) 1339 - builder.encode_attrs e v; 1340 - (* Phase 2: write all children (will close start tag on first write) *) 1341 - builder.encode_children e v); 1342 - } 1449 + let finish (builder : ('o, 'o) t) : 'o codec = 1450 + El 1451 + ( "", 1452 + { 1453 + el_dec = builder.dec; 1454 + el_fields = List.rev builder.fields; 1455 + el_needs_children = builder.needs_children; 1456 + } ) 1343 1457 end 1344 1458 1345 - (* ── Combinators ────────────────────────────────────────────────────── *) 1459 + (* ── Element wrapper ───────────────────────────────────────────────── *) 1346 1460 1347 - let map ?dec ?enc codec = 1348 - { 1349 - dec_tree = 1350 - (fun el -> 1351 - match codec.dec_tree el with 1352 - | Error e -> Error e 1353 - | Ok v -> ( 1354 - match dec with Some f -> f v | None -> Error "no decoder provided")); 1355 - dec_stream = 1356 - (fun s ~tag ~attrs ~self_close -> 1357 - match codec.dec_stream s ~tag ~attrs ~self_close with 1358 - | Error e -> Error e 1359 - | Ok v -> ( 1360 - match dec with Some f -> f v | None -> Error "no decoder provided")); 1361 - enc = (fun e v -> match enc with Some f -> codec.enc e (f v) | None -> ()); 1362 - } 1461 + let element tag codec = 1462 + match codec with 1463 + | El ("", map) -> 1464 + (* El.finish produced this with empty-string sentinel tag *) 1465 + El (tag, map) 1466 + | _ -> 1467 + (* Wrap any codec in a named element: `element "foo" string` 1468 + produces Element ("foo", Text), decoded/encoded by the 1469 + interpreter as a tag check + delegation to the inner codec. *) 1470 + Element (tag, codec) 1363 1471 1364 - let const v = 1365 - { 1366 - dec_tree = (fun _el -> Ok v); 1367 - dec_stream = (fun _s ~tag:_ ~attrs:_ ~self_close:_ -> Ok v); 1368 - enc = (fun _e _v -> ()); 1369 - } 1472 + (* ── Combinators ───────────────────────────────────────────────────── *) 1370 1473 1371 - let option codec = 1372 - { 1373 - dec_tree = 1374 - (fun el -> 1375 - match codec.dec_tree el with Ok v -> Ok (Some v) | Error _ -> Ok None); 1376 - dec_stream = 1377 - (fun s ~tag ~attrs ~self_close -> 1378 - match codec.dec_stream s ~tag ~attrs ~self_close with 1379 - | Ok v -> Ok (Some v) 1380 - | Error _ -> Ok None); 1381 - enc = (fun e v -> match v with Some v -> codec.enc e v | None -> ()); 1382 - } 1474 + let map ?dec ?enc codec = 1475 + let map_dec = 1476 + match dec with Some f -> f | None -> fun _ -> Error "no decoder provided" 1477 + in 1478 + let map_enc = 1479 + match enc with 1480 + | Some f -> f 1481 + | None -> fun _ -> failwith "no encoder provided" 1482 + in 1483 + Map { dom = codec; map_dec; map_enc } 1383 1484 1384 - let list codec = 1385 - { 1386 - dec_tree = 1387 - (fun el -> 1388 - let child_els = 1389 - List.filter_map 1390 - (function Tree.Element e -> Some e | Tree.Text _ -> None) 1391 - el.children 1392 - in 1393 - let rec decode_all acc = function 1394 - | [] -> Ok (List.rev acc) 1395 - | child_el :: rest -> ( 1396 - match codec.dec_tree child_el with 1397 - | Ok v -> decode_all (v :: acc) rest 1398 - | Error e -> Error e) 1399 - in 1400 - decode_all [] child_els); 1401 - dec_stream = 1402 - (fun s ~tag:_ ~attrs:_ ~self_close -> 1403 - if self_close then Ok [] 1404 - else 1405 - (* Parse child elements from stream and decode each *) 1406 - match stream_collect_children s with 1407 - | Error e -> Error e 1408 - | Ok (children, _text) -> 1409 - let rec decode_all acc = function 1410 - | [] -> Ok (List.rev acc) 1411 - | child_el :: rest -> ( 1412 - match codec.dec_tree child_el with 1413 - | Ok v -> decode_all (v :: acc) rest 1414 - | Error e -> Error e) 1415 - in 1416 - decode_all [] children); 1417 - enc = 1418 - (fun e vs -> 1419 - List.iter 1420 - (fun v -> 1421 - enc_close_start_tag e; 1422 - codec.enc e v) 1423 - vs); 1424 - } 1485 + let const v = Const v 1486 + let option codec = Option codec 1487 + let list codec = List codec 1425 1488 1426 - (* ── Decode / Encode ────────────────────────────────────────────────── *) 1489 + (* ── Decode / Encode ───────────────────────────────────────────────── *) 1427 1490 1428 - (* Stream-based decode: parse the XML preamble, then decode the root 1429 - element directly from the stream using the codec's dec_stream path. *) 1430 1491 let decode_stream codec s = 1431 1492 match P.skip_preamble s with 1432 1493 | Error e -> Error (Printf.sprintf "parse error: %s" e) ··· 1436 1497 match P.parse_start_tag s with 1437 1498 | Error e -> Error (Printf.sprintf "parse error: %s" e) 1438 1499 | Ok (tag, attrs, self_close) -> ( 1439 - match codec.dec_stream s ~tag ~attrs ~self_close with 1500 + match dec_stream codec s ~tag ~attrs ~self_close with 1440 1501 | Error e -> Error e 1441 1502 | Ok v -> Ok v)) 1442 1503 ··· 1448 1509 let encode_string ?(indent = 0) codec v = 1449 1510 let buf = Buffer.create 256 in 1450 1511 let e = make_encoder ~indent (Buffer.add_string buf) in 1451 - codec.enc e v; 1512 + enc_value codec e v; 1452 1513 Buffer.contents buf 1453 1514 1454 1515 let decode codec reader = ··· 1457 1518 1458 1519 let encode ?(indent = 0) codec v writer = 1459 1520 let e = make_encoder ~indent (Bytes.Writer.write_string writer) in 1460 - codec.enc e v 1521 + enc_value codec e v 1522 + 1523 + (* ── Queries ─────────────────────────────────────────────────────────── *) 1524 + 1525 + let get_child tag c = 1526 + (* Build an El with a single required child field that extracts the 1527 + child with the given tag and decodes it with c. The El uses an 1528 + empty-string sentinel tag so it matches any outer element. *) 1529 + let id = Type.Id.make () in 1530 + El 1531 + ( "", 1532 + { 1533 + el_dec = Dec_app (Dec_fun Fun.id, id); 1534 + el_fields = [ Child (tag, c, id, Fun.id) ]; 1535 + el_needs_children = true; 1536 + } ) 1537 + 1538 + let get_attr name = 1539 + (* Build an El with a single required attribute field *) 1540 + let id = Type.Id.make () in 1541 + El 1542 + ( "", 1543 + { 1544 + el_dec = Dec_app (Dec_fun Fun.id, id); 1545 + el_fields = [ Attr (name, Attr.string, id, Fun.id) ]; 1546 + el_needs_children = false; 1547 + } ) 1548 + 1549 + let get_nth n c = 1550 + (* Map over a List codec that extracts the nth child element *) 1551 + Map 1552 + { 1553 + dom = List c; 1554 + map_dec = 1555 + (fun items -> 1556 + match List.nth_opt items n with 1557 + | Some v -> Ok v 1558 + | None -> 1559 + Error 1560 + (Printf.sprintf 1561 + "index %d out of bounds (element has %d children)" n 1562 + (List.length items))); 1563 + map_enc = (fun v -> [ v ]); 1564 + } 1565 + 1566 + (* ── Updates ─────────────────────────────────────────────────────────── *) 1567 + 1568 + let update_child (tag : string) (c : 'a t) : Tree.element t = 1569 + Map 1570 + { 1571 + dom = Raw; 1572 + map_dec = 1573 + (fun el -> 1574 + let found = ref false in 1575 + let new_children = 1576 + List.map 1577 + (fun node -> 1578 + match node with 1579 + | Tree.Element child_el 1580 + when child_el.Tree.tag = tag && not !found -> ( 1581 + found := true; 1582 + match dec_tree c child_el with 1583 + | Ok v -> ( 1584 + let buf = Buffer.create 64 in 1585 + let e = 1586 + make_encoder ~indent:0 (Buffer.add_string buf) 1587 + in 1588 + enc_start_tag e tag; 1589 + enc_value c e v; 1590 + if e.in_start_tag then enc_end_tag_empty e 1591 + else enc_end_tag e tag ~has_elements:false; 1592 + let encoded = Buffer.contents buf in 1593 + match Tree.of_string encoded with 1594 + | Ok new_el -> Tree.Element new_el 1595 + | Error _ -> node) 1596 + | Error _ -> node) 1597 + | _ -> node) 1598 + el.Tree.children 1599 + in 1600 + Ok { el with children = new_children }); 1601 + map_enc = Fun.id; 1602 + } 1603 + 1604 + (* ── Introspection ───────────────────────────────────────────────────── *) 1605 + 1606 + let rec kind : type a. a t -> string = function 1607 + | Text -> "string" 1608 + | Text_map m -> m.base_kind 1609 + | Element (tag, inner) -> "element <" ^ tag ^ "> of " ^ kind inner 1610 + | El (tag, _) -> if tag = "" then "element" else "element <" ^ tag ^ ">" 1611 + | Raw -> "tree" 1612 + | Map mw -> kind mw.dom 1613 + | Const _ -> "constant" 1614 + | Option inner -> "optional " ^ kind inner 1615 + | Rec lz -> kind (Lazy.force lz) 1616 + | List inner -> "list of " ^ kind inner
+36
lib/xmlt.mli
··· 257 257 val find_path : string list -> element -> element option 258 258 (** [find_path ["a"; "b"; "c"] el] navigates a.b.c in the tree. *) 259 259 end 260 + 261 + (** {1:queries Queries} 262 + 263 + Query combinators extract sub-values from XML elements. These are the XML 264 + equivalent of Jsont's "soup" approach: they navigate into the structure of 265 + an already-parsed element. *) 266 + 267 + val get_child : string -> 'a t -> 'a t 268 + (** [get_child tag c] queries a child element by tag name. On decoding, finds 269 + the first direct child element with [tag] and decodes it with [c]. Other 270 + children are ignored. Errors if no child with that tag exists. *) 271 + 272 + val get_attr : string -> string t 273 + (** [get_attr name] queries an attribute value. On decoding, extracts the string 274 + value of attribute [name] from the element. Errors if the attribute is 275 + absent. *) 276 + 277 + val get_nth : int -> 'a t -> 'a t 278 + (** [get_nth n c] queries the [n]th child element. On decoding, collects all 279 + child elements, decodes them with [c], and returns the [n]th one. Errors if 280 + [n] is out of bounds. *) 281 + 282 + (** {1:updates Updates} *) 283 + 284 + val update_child : string -> 'a t -> Tree.element t 285 + (** [update_child tag c] updates a child element. On decoding, finds the first 286 + child with [tag], decodes it with [c], re-encodes the result, and returns 287 + the full tree with the child replaced. On encoding, serializes the tree 288 + element to XML. *) 289 + 290 + (** {1:introspection Introspection} *) 291 + 292 + val kind : 'a t -> string 293 + (** [kind c] returns a human-readable description of the codec's kind. For 294 + example, [kind string] is ["string"], [kind (element "foo" int)] is 295 + ["element <foo>"], [kind (list int)] is ["list of int"]. *)
+128
test/test_xmlt.ml
··· 1130 1130 let s2 = Xmlt.Tree.to_string el2 in 1131 1131 Alcotest.(check string) "large roundtrip" s s2 1132 1132 1133 + (* ── Query / Update / Introspection tests ─────────────────────────── *) 1134 + 1135 + (* get_child: extract a child element by tag *) 1136 + let test_get_child () = 1137 + let codec = Xmlt.get_child "name" Xmlt.string in 1138 + let v = decode_ok codec "<person><name>Alice</name><age>30</age></person>" in 1139 + Alcotest.(check string) "get_child name" "Alice" v 1140 + 1141 + let test_get_child_int () = 1142 + let codec = Xmlt.get_child "age" Xmlt.int in 1143 + let v = decode_ok codec "<person><name>Alice</name><age>30</age></person>" in 1144 + Alcotest.(check int) "get_child age" 30 v 1145 + 1146 + let test_get_child_nested () = 1147 + let codec = Xmlt.get_child "config" (Xmlt.get_child "host" Xmlt.string) in 1148 + let v = 1149 + decode_ok codec 1150 + "<root><config><host>localhost</host><port>8080</port></config></root>" 1151 + in 1152 + Alcotest.(check string) "get_child nested" "localhost" v 1153 + 1154 + let test_get_child_missing () = 1155 + let codec = Xmlt.get_child "email" Xmlt.string in 1156 + decode_err codec "<person><name>Alice</name></person>" 1157 + 1158 + (* get_attr: extract an attribute value *) 1159 + let test_get_attr () = 1160 + let codec = Xmlt.get_attr "name" in 1161 + let v = decode_ok codec {|<person name="Alice"/>|} in 1162 + Alcotest.(check string) "get_attr name" "Alice" v 1163 + 1164 + let test_get_attr_second () = 1165 + let codec = Xmlt.get_attr "age" in 1166 + let v = decode_ok codec {|<person name="Alice" age="30"/>|} in 1167 + Alcotest.(check string) "get_attr age" "30" v 1168 + 1169 + let test_get_attr_missing () = 1170 + let codec = Xmlt.get_attr "email" in 1171 + decode_err codec {|<person name="Alice"/>|} 1172 + 1173 + (* get_nth: extract the nth child element *) 1174 + let test_get_nth () = 1175 + let codec = Xmlt.get_nth 1 Xmlt.string in 1176 + let v = 1177 + decode_ok codec "<root><a>first</a><b>second</b><c>third</c></root>" 1178 + in 1179 + Alcotest.(check string) "get_nth 1" "second" v 1180 + 1181 + let test_get_nth_first () = 1182 + let codec = Xmlt.get_nth 0 Xmlt.int in 1183 + let v = decode_ok codec "<items><n>10</n><n>20</n><n>30</n></items>" in 1184 + Alcotest.(check int) "get_nth 0" 10 v 1185 + 1186 + let test_get_nth_last () = 1187 + let codec = Xmlt.get_nth 2 Xmlt.string in 1188 + let v = decode_ok codec "<items><a>x</a><b>y</b><c>z</c></items>" in 1189 + Alcotest.(check string) "get_nth 2" "z" v 1190 + 1191 + let test_get_nth_out_of_bounds () = 1192 + let codec = Xmlt.get_nth 5 Xmlt.string in 1193 + decode_err codec "<items><a>x</a></items>" 1194 + 1195 + (* update_child: recode a child element *) 1196 + let test_update_child () = 1197 + let codec = Xmlt.update_child "name" Xmlt.string in 1198 + let v = decode_ok codec "<person><name>Alice</name><age>30</age></person>" in 1199 + (* The result is a Tree.element; check that the name child is still there *) 1200 + Alcotest.(check string) "update_child root tag" "person" v.Xmlt.Tree.tag; 1201 + Alcotest.(check (option string)) 1202 + "update_child name preserved" (Some "Alice") 1203 + (Xmlt.Tree.text_of "name" v) 1204 + 1205 + (* kind: introspection *) 1206 + let test_kind_string () = 1207 + Alcotest.(check string) "kind string" "string" (Xmlt.kind Xmlt.string) 1208 + 1209 + let test_kind_int () = 1210 + Alcotest.(check string) "kind int" "int" (Xmlt.kind Xmlt.int) 1211 + 1212 + let test_kind_float () = 1213 + Alcotest.(check string) "kind float" "float" (Xmlt.kind Xmlt.float) 1214 + 1215 + let test_kind_bool () = 1216 + Alcotest.(check string) "kind bool" "bool" (Xmlt.kind Xmlt.bool) 1217 + 1218 + let test_kind_element () = 1219 + let codec = Xmlt.element "foo" Xmlt.string in 1220 + let k = Xmlt.kind codec in 1221 + Alcotest.(check bool) 1222 + "kind element contains foo" true 1223 + (let idx = try String.index k 'f' with Not_found -> -1 in 1224 + idx >= 0) 1225 + 1226 + let test_kind_list () = 1227 + let codec = Xmlt.list Xmlt.int in 1228 + let k = Xmlt.kind codec in 1229 + Alcotest.(check bool) 1230 + "kind list contains list" true 1231 + (String.length k > 0 && k <> "") 1232 + 1233 + let test_kind_option () = 1234 + let codec = Xmlt.option Xmlt.string in 1235 + let k = Xmlt.kind codec in 1236 + Alcotest.(check string) "kind option" "optional string" k 1237 + 1133 1238 (* ── Test suite ─────────────────────────────────────────────────────── *) 1134 1239 1135 1240 let suite = ··· 1316 1421 test_codec_attr_special_chars_roundtrip; 1317 1422 Alcotest.test_case "tree roundtrip mixed" `Quick test_tree_roundtrip_mixed; 1318 1423 Alcotest.test_case "tree roundtrip large" `Quick test_tree_roundtrip_large; 1424 + (* Queries *) 1425 + Alcotest.test_case "get_child string" `Quick test_get_child; 1426 + Alcotest.test_case "get_child int" `Quick test_get_child_int; 1427 + Alcotest.test_case "get_child nested" `Quick test_get_child_nested; 1428 + Alcotest.test_case "get_child missing" `Quick test_get_child_missing; 1429 + Alcotest.test_case "get_attr" `Quick test_get_attr; 1430 + Alcotest.test_case "get_attr second" `Quick test_get_attr_second; 1431 + Alcotest.test_case "get_attr missing" `Quick test_get_attr_missing; 1432 + Alcotest.test_case "get_nth 1" `Quick test_get_nth; 1433 + Alcotest.test_case "get_nth 0" `Quick test_get_nth_first; 1434 + Alcotest.test_case "get_nth 2" `Quick test_get_nth_last; 1435 + Alcotest.test_case "get_nth out of bounds" `Quick 1436 + test_get_nth_out_of_bounds; 1437 + (* Updates *) 1438 + Alcotest.test_case "update_child" `Quick test_update_child; 1439 + (* Introspection *) 1440 + Alcotest.test_case "kind string" `Quick test_kind_string; 1441 + Alcotest.test_case "kind int" `Quick test_kind_int; 1442 + Alcotest.test_case "kind float" `Quick test_kind_float; 1443 + Alcotest.test_case "kind bool" `Quick test_kind_bool; 1444 + Alcotest.test_case "kind element" `Quick test_kind_element; 1445 + Alcotest.test_case "kind list" `Quick test_kind_list; 1446 + Alcotest.test_case "kind option" `Quick test_kind_option; 1319 1447 ] )