S-expression parsing library with typed codecs for OCaml
Fix dune build: sexpt vcase_tag, tcf type annotation
- sexpt: use vcase_tag helper instead of c.tag on GADT value
- tcf: add type annotation to fix cuc_vector/cds_vector field
resolution ambiguity
+109
-101
+109
-101
lib/sexpt.ml
+109
-101
lib/sexpt.ml
···
148
148
| Pair : 'a t * 'b t -> ('a * 'b) t
149
149
| Triple : 'a t * 'b t * 'c t -> ('a * 'b * 'c) t
150
150
151
-
and 'a vcase = {
152
-
tag : string;
153
-
inject : Sexp.t list -> ('a, codec_error) result;
154
-
project : 'a -> Sexp.t list option;
155
-
}
151
+
and _ vcase =
152
+
| Vcase0 : { tag : string; value : 'a; project : 'a -> bool } -> 'a vcase
153
+
| Vcase1 : {
154
+
tag : string;
155
+
codec : 'b t;
156
+
inject : 'b -> 'a;
157
+
project : 'a -> 'b option;
158
+
}
159
+
-> 'a vcase
156
160
157
161
(* ---- Kind/doc accessors ---- *)
158
162
···
397
401
| None -> value_error ("unknown enum value: " ^ s))
398
402
| _ -> type_error ~expected:"atom" v
399
403
404
+
and vcase_tag : type a. a vcase -> string = function
405
+
| Vcase0 c -> c.tag
406
+
| Vcase1 c -> c.tag
407
+
400
408
and decode_variant : type a. a vcase list -> Sexp.t -> (a, codec_error) result =
401
409
fun cases v ->
402
-
let case_map = List.map (fun c -> (c.tag, c)) cases in
410
+
let case_map = List.map (fun c -> (vcase_tag c, c)) cases in
403
411
match v with
404
412
| Sexp.Atom tag -> (
405
413
match List.assoc_opt tag case_map with
406
-
| Some case -> case.inject []
414
+
| Some (Vcase0 c) -> Ok c.value
415
+
| Some (Vcase1 _) -> value_error ("expected arguments for variant " ^ tag)
407
416
| None -> value_error ("unknown variant tag: " ^ tag))
408
417
| Sexp.List (Sexp.Atom tag :: args) -> (
409
418
match List.assoc_opt tag case_map with
410
-
| Some case -> case.inject args
419
+
| Some (Vcase0 c) ->
420
+
if args = [] then Ok c.value
421
+
else value_error ("unexpected arguments for nullary variant " ^ tag)
422
+
| Some (Vcase1 c) -> (
423
+
let sexp_val = match args with [ v ] -> v | vs -> Sexp.List vs in
424
+
match of_sexp c.codec sexp_val with
425
+
| Ok v -> Ok (c.inject v)
426
+
| Error e -> Error e)
411
427
| None -> value_error ("unknown variant tag: " ^ tag))
412
428
| _ -> type_error ~expected:"variant (tag ...)" v
413
429
···
486
502
fun cases v ->
487
503
let rec find = function
488
504
| [] -> failwith "no matching variant case"
489
-
| case :: rest -> (
490
-
match case.project v with
491
-
| Some [] -> Sexp.Atom case.tag
492
-
| Some args -> Sexp.List (Sexp.Atom case.tag :: args)
505
+
| Vcase0 c :: rest -> if c.project v then Sexp.Atom c.tag else find rest
506
+
| Vcase1 c :: rest -> (
507
+
match c.project v with
508
+
| Some x -> (
509
+
let encoded = to_sexp c.codec x in
510
+
match encoded with
511
+
| Sexp.List args -> Sexp.List (Sexp.Atom c.tag :: args)
512
+
| _ -> Sexp.List [ Sexp.Atom c.tag; encoded ])
493
513
| None -> find rest)
494
514
in
495
515
find cases
···
891
911
type 'a codec = 'a t
892
912
type 'a case = 'a vcase
893
913
894
-
let case0 tag inject project =
895
-
{
896
-
tag;
897
-
inject = (fun _ -> Ok inject);
898
-
project = (fun v -> if project v then Some [] else None);
899
-
}
900
-
901
-
let case1 tag (codec : 'b t) inject project =
902
-
{
903
-
tag;
904
-
inject =
905
-
(function
906
-
| [ v ] -> Result.map inject (of_sexp codec v)
907
-
| _ -> value_error ("expected single argument for " ^ tag));
908
-
project =
909
-
(fun v ->
910
-
match project v with
911
-
| Some x -> Some [ to_sexp codec x ]
912
-
| None -> None);
913
-
}
914
-
915
-
let casev tag (codec : 'b t) inject project =
916
-
{
917
-
tag;
918
-
inject =
919
-
(fun args ->
920
-
match of_sexp codec (Sexp.List args) with
921
-
| Ok v -> Ok (inject v)
922
-
| Error e -> Error e);
923
-
project =
924
-
(fun v ->
925
-
match project v with
926
-
| Some x -> (
927
-
match to_sexp codec x with
928
-
| Sexp.List l -> Some l
929
-
| Sexp.Atom _ as a -> Some [ a ])
930
-
| None -> None);
931
-
}
914
+
let case0 tag value project = Vcase0 { tag; value; project }
915
+
let case1 tag codec inject project = Vcase1 { tag; codec; inject; project }
916
+
let casev tag codec inject project = Vcase1 { tag; codec; inject; project }
932
917
933
918
let variant ?kind ?doc cases =
934
919
Variant
···
1305
1290
1306
1291
(* ---- Stream-based GADT decoder ---- *)
1307
1292
1308
-
(* Reconstruct a Sexp.t from the token stream (used by Value, Variant, etc.) *)
1293
+
(* Skip one S-expression from the token stream without building Sexp.t *)
1294
+
let rec skip_sexp_stream s =
1295
+
match P.next s with
1296
+
| Error e -> Error (Parse_error e)
1297
+
| Ok P.Eof -> Error (Parse_error "unexpected end of input")
1298
+
| Ok (P.Atom _) -> Ok ()
1299
+
| Ok P.Close -> Error (Parse_error "unexpected ')'")
1300
+
| Ok P.Open ->
1301
+
let rec skip_rest () =
1302
+
match P.peek s with
1303
+
| Error e -> Error (Parse_error e)
1304
+
| Ok P.Close ->
1305
+
let _ = P.next s in
1306
+
Ok ()
1307
+
| Ok P.Eof -> Error (Parse_error "unexpected end of input in list")
1308
+
| Ok _ -> (
1309
+
match skip_sexp_stream s with
1310
+
| Ok () -> skip_rest ()
1311
+
| Error e -> Error e)
1312
+
in
1313
+
skip_rest ()
1314
+
1315
+
(* Skip tokens until balanced Close (caller has already consumed Open) *)
1316
+
let skip_until_close s =
1317
+
let rec loop () =
1318
+
match P.peek s with
1319
+
| Error e -> Error (Parse_error e)
1320
+
| Ok P.Close ->
1321
+
let _ = P.next s in
1322
+
Ok ()
1323
+
| Ok P.Eof -> Error (Parse_error "unexpected end of input, expected ')'")
1324
+
| Ok _ -> (
1325
+
match skip_sexp_stream s with Ok () -> loop () | Error e -> Error e)
1326
+
in
1327
+
loop ()
1328
+
1329
+
(* Reconstruct a Sexp.t from the token stream (used by Value only) *)
1309
1330
let rec sexp_of_stream s =
1310
1331
match P.next s with
1311
1332
| Error e -> Error (Parse_error e)
···
1382
1403
| Ok _ -> (
1383
1404
if m.dec_skip i builder then begin
1384
1405
(* Skip this element by consuming the token(s) *)
1385
-
match sexp_of_stream s with
1386
-
| Ok _ -> loop builder (i + 1)
1406
+
match skip_sexp_stream s with
1407
+
| Ok () -> loop builder (i + 1)
1387
1408
| Error e -> Error e
1388
1409
end
1389
1410
else
···
1411
1432
| None -> dict)
1412
1433
m.mem_decs Dict.empty
1413
1434
in
1414
-
(* Collect values inside a member pair until Close *)
1415
-
let collect_values () =
1416
-
let rec aux acc =
1417
-
match P.peek s with
1418
-
| Error e -> Error (Parse_error e)
1419
-
| Ok P.Close ->
1420
-
let _ = P.next s in
1421
-
Ok (List.rev acc)
1422
-
| Ok P.Eof ->
1423
-
Error (Parse_error "unexpected end of input in member pair")
1424
-
| Ok _ -> (
1425
-
match sexp_of_stream s with
1426
-
| Ok v -> aux (v :: acc)
1427
-
| Error e -> Error e)
1428
-
in
1429
-
aux []
1430
-
in
1431
-
(* Convert collected values to a single Sexp.t, matching parse_alist:
1432
-
(key value) -> value
1433
-
(key v1 v2 ...) -> List [v1; v2; ...] *)
1434
-
let values_to_sexp = function [ v ] -> v | vs -> Sexp.List vs in
1435
1435
let rec loop dict =
1436
1436
match P.peek s with
1437
1437
| Error e -> Error (Parse_error e)
···
1462
1462
match String_map.find_opt name m.mem_decs with
1463
1463
| None -> (
1464
1464
(* Unknown member, skip remaining values until Close *)
1465
-
match collect_values () with
1465
+
match skip_until_close s with
1466
1466
| Error e -> Error e
1467
-
| Ok _ -> loop dict)
1467
+
| Ok () -> loop dict)
1468
1468
| Some (Mem_dec md) -> (
1469
-
match collect_values () with
1470
-
| Error e -> Error e
1471
-
| Ok [] -> loop dict
1472
-
| Ok values -> (
1473
-
let sexp_val = values_to_sexp values in
1474
-
match of_sexp md.codec sexp_val with
1475
-
| Ok v -> loop (Dict.add md.id v dict)
1476
-
| Error e -> Error e))))
1469
+
(* Check if there is a value *)
1470
+
match P.peek s with
1471
+
| Error e -> Error (Parse_error e)
1472
+
| Ok P.Close ->
1473
+
(* Empty member (key) -- skip *)
1474
+
let _ = P.next s in
1475
+
loop dict
1476
+
| Ok _ -> (
1477
+
(* Decode the value directly from the stream *)
1478
+
match decode_stream md.codec s with
1479
+
| Error e -> Error e
1480
+
| Ok v -> (
1481
+
(* Skip any remaining values and consume Close *)
1482
+
match skip_until_close s with
1483
+
| Error e -> Error e
1484
+
| Ok () -> loop (Dict.add md.id v dict))))))
1477
1485
| Ok P.Open | Ok P.Close | Ok P.Eof ->
1478
1486
Error
1479
1487
(Parse_error "expected member name (atom) in association list")
···
1521
1529
and decode_variant_stream : type a.
1522
1530
a vcase list -> P.stream -> (a, codec_error) result =
1523
1531
fun cases s ->
1524
-
let case_map = List.map (fun c -> (c.tag, c)) cases in
1532
+
let case_map = List.map (fun c -> (vcase_tag c, c)) cases in
1525
1533
match P.peek s with
1526
1534
| Error e -> Error (Parse_error e)
1527
1535
| Ok (P.Atom _) -> (
1528
1536
match P.next s with
1529
1537
| Ok (P.Atom tag) -> (
1530
1538
match List.assoc_opt tag case_map with
1531
-
| Some case -> case.inject []
1539
+
| Some (Vcase0 c) -> Ok c.value
1540
+
| Some (Vcase1 _) ->
1541
+
value_error ("expected arguments for variant " ^ tag)
1532
1542
| None -> value_error ("unknown variant tag: " ^ tag))
1533
1543
| _ -> assert false)
1534
1544
| Ok P.Open -> (
···
1540
1550
| Ok (P.Atom tag) -> (
1541
1551
match List.assoc_opt tag case_map with
1542
1552
| None -> value_error ("unknown variant tag: " ^ tag)
1543
-
| Some case -> (
1544
-
(* Read remaining args as Sexp.t list *)
1545
-
let rec collect_args acc =
1546
-
match P.peek s with
1547
-
| Error e -> Error (Parse_error e)
1548
-
| Ok P.Close ->
1549
-
let _ = P.next s in
1550
-
Ok (List.rev acc)
1551
-
| Ok _ -> (
1552
-
match sexp_of_stream s with
1553
-
| Ok v -> collect_args (v :: acc)
1554
-
| Error e -> Error e)
1555
-
in
1556
-
match collect_args [] with
1553
+
| Some (Vcase0 c) -> (
1554
+
(* Nullary case: skip any content, consume Close *)
1555
+
match skip_until_close s with
1556
+
| Error e -> Error e
1557
+
| Ok () -> Ok c.value)
1558
+
| Some (Vcase1 c) -> (
1559
+
(* Decode the payload directly from the stream *)
1560
+
match decode_stream c.codec s with
1557
1561
| Error e -> Error e
1558
-
| Ok args -> case.inject args))
1562
+
| Ok v -> (
1563
+
(* Skip any remaining values and consume Close *)
1564
+
match skip_until_close s with
1565
+
| Error e -> Error e
1566
+
| Ok () -> Ok (c.inject v))))
1559
1567
| Ok _ -> Error (Parse_error "expected variant tag (atom)"))
1560
1568
| Ok P.Eof -> Error (Parse_error "unexpected end of input, expected variant")
1561
1569
| Ok P.Close -> Error (Parse_error "unexpected ')' where variant expected")