From ffc860c2f101d35c3058f3684d54c32230d7c6ea Mon Sep 17 00:00:00 2001 From: Leandro Ostera Date: Sun, 25 Feb 2024 08:44:14 +0100 Subject: [PATCH] chore: clean up core/derive --- Makefile | 21 - README.md | 109 +---- derive/attributes.ml | 81 ---- derive/de.ml | 565 ------------------------- derive/dune | 12 - derive/ppx.t/.ocamlformat | 0 derive/ppx.t/dune | 11 - derive/ppx.t/dune-project | 1 - derive/ppx.t/ppx_test.ml | 45 -- derive/ppx.t/record_test.ml | 49 --- derive/ppx.t/run.t | 678 ------------------------------ derive/ppx.t/variant_test.ml | 28 -- derive/ser.ml | 227 ---------- dune-project | 28 +- examples/dune | 5 - examples/starfleet.ml | 32 -- serde.opam | 33 -- serde/dune | 10 - serde/serde.ml | 764 ---------------------------------- serde/serde_test.ml | 611 --------------------------- serde_derive.opam | 33 -- serde_json.opam | 6 +- serde_json/serde_json_test.ml | 2 +- 23 files changed, 8 insertions(+), 3343 deletions(-) delete mode 100644 Makefile delete mode 100644 derive/attributes.ml delete mode 100644 derive/de.ml delete mode 100644 derive/dune delete mode 100644 derive/ppx.t/.ocamlformat delete mode 100644 derive/ppx.t/dune delete mode 100644 derive/ppx.t/dune-project delete mode 100644 derive/ppx.t/ppx_test.ml delete mode 100644 derive/ppx.t/record_test.ml delete mode 100644 derive/ppx.t/run.t delete mode 100644 derive/ppx.t/variant_test.ml delete mode 100644 derive/ser.ml delete mode 100644 examples/dune delete mode 100644 examples/starfleet.ml delete mode 100644 serde.opam delete mode 100644 serde/dune delete mode 100644 serde/serde.ml delete mode 100644 serde/serde_test.ml delete mode 100644 serde_derive.opam diff --git a/Makefile b/Makefile deleted file mode 100644 index 72465df..0000000 --- a/Makefile +++ /dev/null @@ -1,21 +0,0 @@ - -.PHONY: all -all: - dune build @all --watch - -.PHONY: test -test: - dune test - -.PHONY: clean -clean: - dune clean - -.PHONY: fmt -fmt: - dune build @fmt --auto-promote - -.PHONY: setup -setup: - opam install dune ppx_deriving ppxlib ocamlformat ocaml-lsp-server ppx_inline_test -y - opam install sexplib yojson tyxml -y diff --git a/README.md b/README.md index 9c6d43e..1d7b9e1 100644 --- a/README.md +++ b/README.md @@ -1,108 +1,3 @@ -# serde.ml +# serde_json -A serialization framework for OCaml inspired by [serde-rs](https://github.com/serde-rs). - -The main goals for `serde.ml` are: - -* **Serialization** -- take arbitary data structures from the user and turn them into specific formats with maximum efficiency. - -* **Deserialization** -- read arbitrary data that you parse into data structures of the user's choice with maximum efficiency. - -> NOTE: this is _super not ready_ for production yet, but all contributions are welcome <3 - -```ocaml -type rank = Captain | Chief_petty_officer [@@deriving serializer, deserializer] -type t = { name : string; rank : rank } [@@deriving serializer, deserializer] - -let obrien = { name = "Miles O'Brien"; rank = Chief_petty_officer } -let sisko = { name = "Benjamin Sisko"; rank = Captain } - -> Serde_json.to_string_pretty (serialize_t) obrien -Ok "{ \"name\": \"Miles O'Brien\", \"rank\": \"Chief_petty_officer\" }" - -> Serde_json.of_string (deserialize_t) "{ \"name\": \"Miles O'Brien\", \"rank\": \"Chief_petty_officer\" }" -Ok {name = "Miles O'Brien"; rank = Chief_petty_officer} - -> Serde_sexpr.to_string_pretty (serialize_t) obrien;; -Ok "(\"Miles O'Brien\" :Chief_petty_officer)" - -> Serde_sexpr.of_string (deserialize_t) "(\"Miles O'Brien\" :Chief_petty_officer)";; -Ok {name = "Miles O'Brien"; rank = Chief_petty_officer} -``` - -### Usage - -Set up the `serde_derive` ppx, and bring in any data format modules you want to use. Here we bring s-expressions and json. - -```dune -(library - (name my_lib) - (preprocess (pps serde_derive)) - (libraries serde serde_derive serde_sexpr serde_json)) -``` - -Tag your data structures with `deriving (serializer, deserializer)`. - -```ocaml -open Serde - -type t = - | Hello - | Tuple1 of string - | Tuple2 of string * bool - | Record3 of { name : string; favorite_number : int; location : string } -[@@deriving (serializer, deserializer)] -``` - -Now you have a `serialize_{typeName}` and `deserialize_{typeName}` functions that you can pass into the different data format modules. - -To read data, use `deserialize_t` like this: - -```ocaml -let sexpr = "(:Record3 (\"Benjamin Sisko\" 9 \"Bajor\"))" in -let* t = Serde_sexpr.of_string deserialize_t sexpr in -t = (Record3 { name = "Benjamin Sisko"; favorite_number = 9; location = "Bajor" }) -``` - -To render data, use `serialize_t` like this: - -```ocaml -let t = (Record3 { name = "Benjamin Sisko"; favorite_number = 9; location = "Bajor" }) in -let* sexpr = Serde_sexpr.to_string_pretty serialize_t t in -sexpr = "(:Record3 (\"Benjamin Sisko\" 9 \"Bajor\"))" -``` - -To transcode data across formats, switch the data module: - -```ocaml -(* read sexpr *) -let sexpr = "(:Record3 (\"Benjamin Sisko\" 9 \"Bajor\"))" in -let* t = Serde_sexpr.of_string deserialize_t sexpr in -(* write json *) -let* json = Serde_json.to_string_pretty serialize_t t in -json = "{ - \"t#Record3\": { - \"name\": \"Benjamin Sisko\", - \"favorite_number\": 9, - \"location\": \"Deep Space 9\" - } -}" -``` - -## Contributing - -Check the [CONTRIBUTING.md](./CONTRIBUTING.md) for a small guide on how to -implement new data formats. - -## Advanced Use: Custom Serializer/Deserializer - -Serde.ml is capable of deriving the right serializer/deserializer for your -types (and it if doesn't, that's a bug!) but in some cases you want to fit some -external data format into an existing internal representation without having to -add an extra layer. - -In those cases, you can implement a Serde _Visitor_ and customize absolutely -everything about it. You can get started by using `serde_derive` and `dune -describe pp` to expand the derivation. This will give you a solid starting -point for your data type, where you can see how the generated Visitor drives -the Deserializer by asking it to deserialize specific datatypes. +JSON support for Serde, a serialization framework for OCaml. diff --git a/derive/attributes.ml b/derive/attributes.ml deleted file mode 100644 index 0351472..0000000 --- a/derive/attributes.ml +++ /dev/null @@ -1,81 +0,0 @@ -open Ppxlib - -type type_attributes = { - rename : string; - mode : - [ `tag of string - | `tag_and_content of string * string - | `untagged - | `normal ]; - rename_all : - [ `lowercase - | `UPPERCASE - | `camelCase - | `PascalCase - | `snake_case - | `SCREAMING_SNAKE_CASE - | `kebab_case - | `SCREAMING_KEBAB_CASE ] - option; - error_on_unknown_fields : bool; -} - -type variant_attributes = { - rename : string; - should_skip : [ `skip_serializing | `skip_deserializing | `always | `never ]; - is_catch_all : bool; -} - -type field_attributes = { - name : string; - presence : [ `required | `optional | `with_default of Parsetree.expression ]; - should_skip : - [ `skip_serializing_if of string - | `skip_deserializing_if of string - | `always - | `never ]; -} - -let of_field_attributes lbl = - let open Ppxlib in - let name = ref lbl.pld_name.txt in - let should_skip = ref `never in - let presence = - ref - (match lbl.pld_type.ptyp_desc with - | Ptyp_constr ({ txt = Lident "option"; _ }, _) -> `optional - | _ -> `required) - in - let () = - match lbl.pld_attributes with - | [ - { - attr_name = { txt = "serde"; _ }; - attr_payload = - PStr - [ - { - pstr_desc = - Pstr_eval ({ pexp_desc = Pexp_record (fields, _); _ }, _); - _; - }; - ]; - _; - }; - ] -> - List.iter - (fun (label, expr) -> - match (label, expr) with - | ( { txt = Lident "rename"; _ }, - { pexp_desc = Pexp_constant (Pconst_string (s, _, _)); _ } ) -> - name := s; - () - | { txt = Lident "default"; _ }, expr -> - presence := `with_default expr; - () - | _ -> ()) - fields - | _ -> () - in - - (lbl, { name = !name; presence = !presence; should_skip = !should_skip }) diff --git a/derive/de.ml b/derive/de.ml deleted file mode 100644 index def5c3a..0000000 --- a/derive/de.ml +++ /dev/null @@ -1,565 +0,0 @@ -open Ppxlib -module Ast = Ast_builder.Default - -(** helpers *) -let loc ~ctxt = Expansion_context.Deriver.derived_item_loc ctxt - -let var ~ctxt name = - let loc = loc ~ctxt in - Loc.make ~loc name - -let gensym () = - let counter = ref 0 in - fun ~ctxt -> - counter := !counter + 1; - var ~ctxt ("v_" ^ Int.to_string !counter) - -let deserializer_fn_name_for_longident name = - let name = - match name.txt |> Longident.flatten_exn |> List.rev with - | name :: [] -> "deserialize_" ^ name - | name :: path -> - ("deserialize_" ^ name) :: path |> List.rev |> String.concat "." - | _ -> "unknown" - in - Longident.parse name - -let is_primitive = function - | "bool" | "char" | "float" | "int" | "int32" | "int64" | "string" | "list" - | "array" | "unit" | "option" -> - true - | _ -> false - -(** [deserializer_for_type] creates a call to a deserializer based on a type. - - When type is a constructor (or [Ptyp_constr], which is OCaml for "any type name"), - we will look at the number of arguments it has and - -*) -let rec deserializer_for_type ~ctxt (core_type : Parsetree.core_type) = - let loc = loc ~ctxt in - match core_type.ptyp_desc with - | Ptyp_constr (name, arg :: []) when is_primitive (Longident.name name.txt) -> - let type_ser = deserializer_for_type ~ctxt arg in - let name = Ast.pexp_ident ~loc name in - [%expr d ([%e name] [%e type_ser])] - | Ptyp_constr (name, []) when is_primitive (Longident.name name.txt) -> - Ast.pexp_ident ~loc name - | Ptyp_constr (name, _args) -> - let ser_fn = - deserializer_fn_name_for_longident name - |> var ~ctxt |> Ast.pexp_ident ~loc - in - [%expr d [%e ser_fn]] - | Ptyp_any | Ptyp_var _ - | Ptyp_arrow (_, _, _) - | Ptyp_tuple _ - | Ptyp_object (_, _) - | Ptyp_class (_, _) - | Ptyp_alias (_, _) - | Ptyp_variant (_, _, _) - | Ptyp_poly (_, _) - | Ptyp_package _ | Ptyp_extension _ -> - failwith "unsupported" - -(** implementation *) - -(** Deserializes records in different ways. *) -module Record_deserializer = struct - (** Generates the implementation of a deserializer for a given record type (or - list of label declarations). - - The outline of the generated code is: - - * create a field_visitor that maps strings and ints to an ad-hoc field - polyvar (field name "hello" matches [`hello]) - - * declare field value holders (one 'a option ref per field) - - * create a recursive function for consuimng fields one by one, using - the visitor to validate them, and directing the deserialization to the - right field deserializer - - * extract the field value holders and validate that all fields are present - - * construct the final result - - So for a record like: - - {ocaml[ - type person = { name: string; age: int } - ]} - - The generated code would look like: - - {ocaml[ - let deserialize_person = De.(deserializer @@ fun ctx -> - record ctx "person" 2 @@ fun ctx -> - let field_visitor = Visitor.make - ~visit_string:(fun _ctx str -> - match str with - | "name" -> Ok `name - | "age" -> Ok `age - | _ -> Error `invalid_field_type) - ~visit_int:(fun _ctx int -> - match int with - | 0 -> Ok `name - | 1 -> Ok `age - | _ -> Error `invalid_field_type) - () - in - - let name = ref None in - let age = ref None in - - let rec read_fields () = - let* tag = next_field ctx field_visitor in - match tag with - | Some `name -> - let* v = field ctx "name" string in - name := Some v; - read_fields () - | Some `age -> - let* v = field ctx "age" int in - age := Some v; - read_fields () - | None -> - Ok () - in - let* () = read_fields () in - - let* name = Option.to_result ~none:(`Msg "missing field 'name'") name in - let* age = Option.to_result ~none:(`Msg "missing field 'age'") age in - - Ok {name;age} - ) - ]} -*) - let deserialize_with_unordered_fields ~ctxt labels final_expr = - let loc = loc ~ctxt in - let labels = List.rev labels in - let labels = List.map Attributes.of_field_attributes labels in - - (* NOTE(@leostera): Generate the final assembling of the record value - - {ocaml[ - ... in - Ok { name; age } - ]} - *) - let record_expr = - let fields = - List.map - (fun (field, _) -> - let value = Ast.evar ~loc field.pld_name.txt in - let field = Longident.parse field.pld_name.txt |> var ~ctxt in - (field, value)) - labels - in - let record = Ast.pexp_record ~loc fields None in - final_expr record - in - - (* NOTE(@leostera): Generate the placeholder values for a list of fields: - - {ocaml[ - let name = ref None in - let age = ref None in - ... - ]} - *) - let field_value_holders body = - List.fold_left - (fun last (field, _) -> - let field = Ast.(pvar ~loc field.pld_name.txt) in - [%expr - let [%p field] = ref None in - [%e last]]) - body labels - in - - (* NOTE(@leostera): Generate the placeholder values for a list of fields: - - {ocaml[ - let name = ref None in - let age = ref None in - ... - ]} - *) - let field_value_unwrapping body = - List.fold_left - (fun last (field, attr) -> - let field_var = Ast.(evar ~loc field.pld_name.txt) in - let field_pat = Ast.(pvar ~loc field.pld_name.txt) in - let missing_msg = - Ast.estring ~loc - (Format.sprintf "missing field %S (%S)" - Attributes.(attr.name) - field.pld_name.txt) - in - match Attributes.(attr.presence) with - | `required -> - [%expr - let* [%p field_pat] = - Option.to_result ~none:(`Msg [%e missing_msg]) ![%e field_var] - in - [%e last]] - | `optional -> - [%expr - let [%p field_pat] = - match ![%e field_var] with Some opt -> opt | None -> None - in - [%e last]] - | `with_default str -> - [%expr - let [%p field_pat] = - match ![%e field_var] with - | Some opt -> opt - | None -> [%e str] - in - [%e last]]) - body labels - in - - (* NOTE(@leostera): creates the visito from strings/ints to polymorphic - variants for each field - - {ocaml[ - Visitor.make - ~visit_string:(fun _ctx str -> - match str with - | "name" -> Ok `name - | "age" -> Ok `age - | _ -> Error `invalid_field_type) - ~visit_int:(fun _ctx int -> - match int with - | 0 -> Ok `name - | 1 -> Ok `age - | _ -> Error `invalid_field_type) - () - ]} - *) - let field_visitor next = - let visit_string = - let cases = - List.map - (fun (field, attr) -> - let lhs = Ast.pstring ~loc Attributes.(attr.name) in - let rhs = - let tag = Ast.pexp_variant ~loc field.pld_name.txt None in - [%expr Ok [%e tag]] - in - Ast.case ~lhs ~rhs ~guard:None) - labels - @ [ - Ast.case ~lhs:(Ast.ppat_any ~loc) ~guard:None - ~rhs:[%expr Error `invalid_tag]; - ] - in - let body = Ast.pexp_match ~loc [%expr str] cases in - [%expr fun _ctx str -> [%e body]] - in - - let visit_int = - let cases = - List.mapi - (fun idx (field, _) -> - let lhs = Ast.pint ~loc idx in - let rhs = - let tag = Ast.pexp_variant ~loc field.pld_name.txt None in - [%expr Ok [%e tag]] - in - Ast.case ~lhs ~rhs ~guard:None) - labels - @ [ - Ast.case ~lhs:(Ast.ppat_any ~loc) ~guard:None - ~rhs:[%expr Error `invalid_tag]; - ] - in - let body = Ast.pexp_match ~loc [%expr str] cases in - [%expr fun _ctx str -> [%e body]] - in - - [%expr - let field_visitor = - let visit_string = [%e visit_string] in - let visit_int = [%e visit_int] in - Visitor.make ~visit_string ~visit_int () - in - [%e next]] - in - - let declare_read_fields next = - let cases = - List.mapi - (fun _idx (label, attrs) -> - let lhs = - let tag = Ast.ppat_variant ~loc label.pld_name.txt None in - Ast.ppat_construct ~loc - Longident.(parse "Some" |> var ~ctxt) - (Some tag) - in - let rhs = - (* let field_name = Ast.estring ~loc label.pld_name.txt in *) - let field_name = Ast.estring ~loc Attributes.(attrs.name) in - let field_var = Ast.(evar ~loc label.pld_name.txt) in - let deserializer = deserializer_for_type ~ctxt label.pld_type in - let assign = - Ast.( - pexp_apply ~loc - (pexp_ident ~loc (var ~ctxt (Longident.parse ":="))) - [ (Nolabel, field_var); (Nolabel, [%expr Some v]) ]) - in - [%expr - let* v = field ctx [%e field_name] [%e deserializer] in - [%e assign]; - read_fields ()] - in - Ast.case ~lhs ~guard:None ~rhs) - labels - @ [ - Ast.case - ~lhs: - (Ast.ppat_construct ~loc - Longident.(parse "None" |> var ~ctxt) - None) - ~guard:None ~rhs:[%expr Ok ()]; - ] - in - - let tag_match = Ast.pexp_match ~loc [%expr tag] cases in - - [%expr - let rec read_fields () = - let* tag = next_field ctx field_visitor in - [%e tag_match] - in - [%e next]] - in - - let call_read_fields next = - [%expr - let* () = read_fields () in - [%e next]] - in - - field_visitor - (* declare all the optional references *) - @@ field_value_holders - (* declare our recursive function for consuming fields *) - @@ declare_read_fields - (* here's where the magic happens *) - @@ call_read_fields - (* unwrap all the boxes *) - @@ field_value_unwrapping - (* build the record *) - @@ record_expr -end - -let gen_deserialize_variant_impl ~ctxt ptype_name cstr_declarations = - let loc = loc ~ctxt in - let type_name = Ast.estring ~loc ptype_name.txt in - let constructor_names = - Ast.elist ~loc - (List.map - (fun (cstr : Parsetree.constructor_declaration) -> - Ast.estring ~loc cstr.pcd_name.txt) - cstr_declarations) - in - - let deser_by_constructor _type_name idx cstr = - let _idx = Ast.eint ~loc idx in - let name = Longident.parse cstr.pcd_name.txt |> var ~ctxt in - match cstr.pcd_args with - (* NOTE(@leostera): deserialize a single unit variant by calling - `unit_variant` directly *) - | Pcstr_tuple [] -> - let value = Ast.pexp_construct ~loc name None in - [%expr - let* () = unit_variant ctx in - Ok [%e value]] - (* NOTE(@leostera): deserialize a newtype variant *) - | Pcstr_tuple [ arg ] -> - let sym = gensym () ~ctxt in - let arg_pat = Ast.pvar ~loc sym.txt in - let arg_var = Ast.evar ~loc sym.txt in - - let value = - let cstr = Ast.pexp_construct ~loc name (Some arg_var) in - [%expr Ok [%e cstr]] - in - - let ser_fn = deserializer_for_type ~ctxt arg in - let body = - [%expr - let* [%p arg_pat] = [%e ser_fn] ctx in - [%e value]] - in - - [%expr newtype_variant ctx @@ fun ctx -> [%e body]] - (* NOTE(@leostera): deserialize a tuple variant *) - | Pcstr_tuple args -> - let gensym = gensym () in - let arg_count = Ast.eint ~loc (List.length args) in - let calls = - List.mapi - (fun _idx arg -> - let ser_fn = deserializer_for_type ~ctxt arg in - let arg_var = (gensym ~ctxt).txt in - let deser = - [%expr - match element ctx [%e ser_fn] with - | Ok (Some v) -> Ok v - | Ok None -> Error `no_more_data - | Error reason -> Error reason] - in - - (arg_var, deser)) - args - in - - let calls = - let args = - Ast.pexp_tuple ~loc - (List.map (fun (field, _) -> Ast.evar ~loc field) calls) - in - let cstr = Ast.pexp_construct ~loc name (Some args) in - - List.fold_left - (fun last (field, expr) -> - let field = Ast.pvar ~loc field in - [%expr - let* [%p field] = [%e expr] in - [%e last]]) - [%expr Ok [%e cstr]] - (List.rev calls) - in - [%expr - tuple_variant ctx [%e arg_count] (fun ~size ctx -> - ignore size; - [%e calls])] - (* NOTE(@leostera): deserialize a record_variant *) - | Pcstr_record labels -> - let field_count = Ast.eint ~loc (List.length labels) in - let body = - Record_deserializer.deserialize_with_unordered_fields ~ctxt labels - @@ fun record -> - let cstr = Ast.pexp_construct ~loc name (Some record) in - [%expr Ok [%e cstr]] - in - - [%expr - record_variant ctx [%e field_count] (fun ~size ctx -> - ignore size; - [%e body])] - in - - let tag_dispatch = - let cases = - List.mapi - (fun idx (cstr : Parsetree.constructor_declaration) -> - let lhs = Ast.ppat_variant ~loc cstr.pcd_name.txt None in - let rhs = deser_by_constructor type_name idx cstr in - Ast.case ~lhs ~guard:None ~rhs) - cstr_declarations - in - - Ast.pexp_match ~loc [%expr tag] cases - in - - let field_visitor = - let cases = - List.mapi - (fun _idx (cstr : Parsetree.constructor_declaration) -> - let tag_name = cstr.pcd_name.txt in - let lhs = Ast.ppat_constant ~loc (Ast_helper.Const.string tag_name) in - let rhs = - let tag = Ast.pexp_variant ~loc cstr.pcd_name.txt None in - [%expr Ok [%e tag]] - in - Ast.case ~lhs ~guard:None ~rhs) - cstr_declarations - @ [ - Ast.case ~lhs:(Ast.ppat_any ~loc) ~guard:None - ~rhs:[%expr Error `invalid_tag]; - ] - in - - let tag_match = Ast.pexp_match ~loc [%expr str] cases in - - [%expr Visitor.make ~visit_string:(fun _ctx str -> [%e tag_match]) ()] - in - - [%expr - let field_visitor = [%e field_visitor] in - variant ctx [%e type_name] [%e constructor_names] @@ fun ctx -> - let* tag = identifier ctx field_visitor in - [%e tag_dispatch]] - -(** Generate the deserializer function for a record type. - - See [Record_deserializer] above for more info. -*) -let gen_deserialize_record_impl ~ctxt ptype_name label_declarations = - let loc = loc ~ctxt in - let type_name = Ast.estring ~loc ptype_name.txt in - let field_count = Ast.eint ~loc (List.length label_declarations) in - - let body = - Record_deserializer.deserialize_with_unordered_fields ~ctxt - label_declarations - @@ fun record -> [%expr Ok [%e record]] - in - - [%expr record ctx [%e type_name] [%e field_count] (fun ctx -> [%e body])] - -(** Generates a deserializer implementation dispatching based on the kind of - type that the [@@deriving] attribute was set on. -*) -let gen_deserialize_impl ~ctxt type_decl = - let loc = loc ~ctxt in - - let typename = type_decl.ptype_name.txt in - - let body = - match type_decl with - | { ptype_kind = Ptype_record label_declarations; ptype_name; _ } -> - gen_deserialize_record_impl ~ctxt ptype_name label_declarations - | { ptype_kind = Ptype_variant cstrs_declaration; ptype_name; _ } -> - gen_deserialize_variant_impl ~ctxt ptype_name cstrs_declaration - | { ptype_kind; ptype_name; _ } -> - let err = - match ptype_kind with - | Ptype_abstract -> "unsupported abstract type" - | Ptype_variant _ -> "unsupported variant type" - | Ptype_record _ -> "unsupported record type" - | Ptype_open -> "unsupported open type" - in - [%expr - [%e ptype_name.txt |> Ast.estring ~loc] [%e err |> Ast.estring ~loc]] - in - let deserializer_name = - "deserialize_" ^ typename |> var ~ctxt |> Ast.ppat_var ~loc - in - [%stri - let [%p deserializer_name] = - let ( let* ) = Result.bind in - Serde.De.(fun ctx -> [%e body])] - -let generate_impl ~ctxt (_rec_flag, type_declarations) = - let loc = loc ~ctxt in - [ [%stri open! Serde]; [%stri let ( let* ) = Result.bind] ] - @ List.map (gen_deserialize_impl ~ctxt) type_declarations - -let impl_generator = Deriving.Generator.V2.make_noarg generate_impl - -(** interface *) - -let generate_intf ~ctxt:_ (_rec_flag, _type_declarations) = [] -let intf_generator = Deriving.Generator.V2.make_noarg generate_intf - -(** registration *) - -let register = - Deriving.add "deserialize" ~str_type_decl:impl_generator - ~sig_type_decl:intf_generator diff --git a/derive/dune b/derive/dune deleted file mode 100644 index 80b33ed..0000000 --- a/derive/dune +++ /dev/null @@ -1,12 +0,0 @@ -(library - (public_name serde_derive) - (kind ppx_rewriter) - (libraries compiler-libs ppxlib serde) - (preprocess - (pps ppxlib.metaquot))) - -(cram - (deps - (package serde) - (package serde_derive) - (package serde_json))) diff --git a/derive/ppx.t/.ocamlformat b/derive/ppx.t/.ocamlformat deleted file mode 100644 index e69de29..0000000 diff --git a/derive/ppx.t/dune b/derive/ppx.t/dune deleted file mode 100644 index 874926f..0000000 --- a/derive/ppx.t/dune +++ /dev/null @@ -1,11 +0,0 @@ -(executable - (name record_test) - (modules record_test) - (preprocess (pps serde_derive)) - (libraries serde serde_json)) - -(executable - (name variant_test) - (modules variant_test) - (preprocess (pps serde_derive)) - (libraries serde serde_json)) diff --git a/derive/ppx.t/dune-project b/derive/ppx.t/dune-project deleted file mode 100644 index cac3ad3..0000000 --- a/derive/ppx.t/dune-project +++ /dev/null @@ -1 +0,0 @@ -(lang dune 3.12) diff --git a/derive/ppx.t/ppx_test.ml b/derive/ppx.t/ppx_test.ml deleted file mode 100644 index 1265a86..0000000 --- a/derive/ppx.t/ppx_test.ml +++ /dev/null @@ -1,45 +0,0 @@ -type rank = { - rank_scores : string list; - rank_name : string; -} -[@@deriving serializer, deserializer] - -type t = { - name : string; - commisioned : bool; - updated_at: int64; - credits: int32 option; - keywords: string array; - rank: rank -} -[@@deriving serializer, deserializer] - -type t_list = { stuff : t list } -[@@deriving serializer, deserializer] - -let () = - let test_t = { - stuff = [ - { - name = "hello"; - commisioned = false; - updated_at = Int64.(sub max_int 1L); - credits = None; - keywords = [||]; - rank = { rank_name = "asdf"; rank_scores = ["1";"c";"a"]} - }; - { - name = "hello"; - commisioned = false; - updated_at = 0L; - credits = Some 2112l; - keywords = [|"hello"|]; - rank = { rank_name = "asdf"; rank_scores = []} - } - ] - } - in - let json1 = Serde_json.to_string serialize_t_list test_t |> Result.get_ok in - let value = Serde_json.of_string deserialize_t_list json1 |> Result.get_ok in - let json2 = Serde_json.to_string serialize_t_list value |> Result.get_ok in - Format.printf "[%s,%s]\n%!" json1 json2 diff --git a/derive/ppx.t/record_test.ml b/derive/ppx.t/record_test.ml deleted file mode 100644 index 2b6475a..0000000 --- a/derive/ppx.t/record_test.ml +++ /dev/null @@ -1,49 +0,0 @@ -type rank = { rank_scores : string list; rank_name : string } -[@@deriving serialize, deserialize] - -type t = { - name : string; - commisioned : bool; - updated_at : int64; - credits : int32 option; - keywords : string array; - rank : rank; - value : float; - type_ : string; [@serde { rename = "type" }] -} -[@@deriving serialize, deserialize] - -type t_list = { stuff : t list } [@@deriving serialize, deserialize] - -let () = - let test_t = - { - stuff = - [ - { - name = "hello"; - commisioned = false; - updated_at = 9223372036854766L; - credits = None; - keywords = [||]; - rank = { rank_name = "asdf"; rank_scores = [ "1"; "c"; "a" ] }; - value = 420.69; - type_ = "something"; - }; - { - name = "hello"; - commisioned = false; - updated_at = 0L; - credits = Some 2112l; - keywords = [| "hello" |]; - rank = { rank_name = "asdf"; rank_scores = [] }; - value = Float.pi; - type_ = "something"; - }; - ]; - } - in - let json1 = Serde_json.to_string serialize_t_list test_t |> Result.get_ok in - let value = Serde_json.of_string deserialize_t_list json1 |> Result.get_ok in - let json2 = Serde_json.to_string serialize_t_list value |> Result.get_ok in - Format.printf "[%s,%s]\n%!" json1 json2 diff --git a/derive/ppx.t/run.t b/derive/ppx.t/run.t deleted file mode 100644 index 5256f77..0000000 --- a/derive/ppx.t/run.t +++ /dev/null @@ -1,678 +0,0 @@ - $ dune clean - $ dune exec ./record_test.exe | jq . - [ - { - "stuff": [ - { - "name": "hello", - "commisioned": false, - "updated_at": 9223372036854766, - "credits": null, - "keywords": [], - "rank": { - "rank_scores": [ - "1", - "c", - "a" - ], - "rank_name": "asdf" - }, - "value": 420.69, - "type": "something" - }, - { - "name": "hello", - "commisioned": false, - "updated_at": 0, - "credits": 2112, - "keywords": [ - "hello" - ], - "rank": { - "rank_scores": [], - "rank_name": "asdf" - }, - "value": 3.14159265359, - "type": "something" - } - ] - }, - { - "stuff": [ - { - "name": "hello", - "commisioned": false, - "updated_at": 9223372036854766, - "credits": null, - "keywords": [], - "rank": { - "rank_scores": [ - "1", - "c", - "a" - ], - "rank_name": "asdf" - }, - "value": 420.69, - "type": "something" - }, - { - "name": "hello", - "commisioned": false, - "updated_at": 0, - "credits": 2112, - "keywords": [ - "hello" - ], - "rank": { - "rank_scores": [], - "rank_name": "asdf" - }, - "value": 3.14159265359, - "type": "something" - } - ] - } - ] - $ dune describe pp ./record_test.ml - [@@@ocaml.ppx.context - { - tool_name = "ppx_driver"; - include_dirs = []; - load_path = []; - open_modules = []; - for_package = None; - debug = false; - use_threads = false; - use_vmthreads = false; - recursive_types = false; - principal = false; - transparent_modules = false; - unboxed_types = false; - unsafe_string = false; - cookies = [] - }] - type rank = { - rank_scores: string list ; - rank_name: string }[@@deriving (serialize, deserialize)] - include - struct - let _ = fun (_ : rank) -> () - let ( let* ) = Result.bind - let _ = ( let* ) - let serialize_rank = - let open Serde.Ser in - fun t -> - fun ctx -> - record ctx "rank" 2 - (fun ctx -> - let* () = - field ctx "rank_scores" ((s (list string)) t.rank_scores) - in - let* () = field ctx "rank_name" (string t.rank_name) - in Ok ()) - let _ = serialize_rank - open! Serde - let ( let* ) = Result.bind - let _ = ( let* ) - let deserialize_rank = - let ( let* ) = Result.bind in - let open Serde.De in - fun ctx -> - record ctx "rank" 2 - (fun ctx -> - let field_visitor = - let visit_string _ctx str = - match str with - | "rank_name" -> Ok `rank_name - | "rank_scores" -> Ok `rank_scores - | _ -> Error `invalid_tag in - let visit_int _ctx str = - match str with - | 0 -> Ok `rank_name - | 1 -> Ok `rank_scores - | _ -> Error `invalid_tag in - Visitor.make ~visit_string ~visit_int () in - let rank_scores = ref None in - let rank_name = ref None in - let rec read_fields () = - let* tag = next_field ctx field_visitor - in - match tag with - | Some `rank_name -> - let* v = field ctx "rank_name" string - in (rank_name := (Some v); read_fields ()) - | Some `rank_scores -> - let* v = field ctx "rank_scores" (d (list string)) - in (rank_scores := (Some v); read_fields ()) - | None -> Ok () in - let* () = read_fields () - in - let* rank_scores = - Option.to_result - ~none:(`Msg - "missing field \"rank_scores\" (\"rank_scores\")") - (!rank_scores) - in - let* rank_name = - Option.to_result - ~none:(`Msg "missing field \"rank_name\" (\"rank_name\")") - (!rank_name) - in Ok { rank_name; rank_scores }) - let _ = deserialize_rank - end[@@ocaml.doc "@inline"][@@merlin.hide ] - type t = - { - name: string ; - commisioned: bool ; - updated_at: int64 ; - credits: int32 option ; - keywords: string array ; - rank: rank ; - value: float ; - type_: string [@serde { rename = "type" }]}[@@deriving - (serialize, deserialize)] - include - struct - let _ = fun (_ : t) -> () - let ( let* ) = Result.bind - let _ = ( let* ) - let serialize_t = - let open Serde.Ser in - fun t -> - fun ctx -> - record ctx "t" 8 - (fun ctx -> - let* () = field ctx "name" (string t.name) - in - let* () = field ctx "commisioned" (bool t.commisioned) - in - let* () = field ctx "updated_at" (int64 t.updated_at) - in - let* () = field ctx "credits" ((s (option int32)) t.credits) - in - let* () = - field ctx "keywords" ((s (array string)) t.keywords) - in - let* () = field ctx "rank" ((s serialize_rank) t.rank) - in - let* () = field ctx "value" (float t.value) - in let* () = field ctx "type" (string t.type_) - in Ok ()) - let _ = serialize_t - open! Serde - let ( let* ) = Result.bind - let _ = ( let* ) - let deserialize_t = - let ( let* ) = Result.bind in - let open Serde.De in - fun ctx -> - record ctx "t" 8 - (fun ctx -> - let field_visitor = - let visit_string _ctx str = - match str with - | "type" -> Ok `type_ - | "value" -> Ok `value - | "rank" -> Ok `rank - | "keywords" -> Ok `keywords - | "credits" -> Ok `credits - | "updated_at" -> Ok `updated_at - | "commisioned" -> Ok `commisioned - | "name" -> Ok `name - | _ -> Error `invalid_tag in - let visit_int _ctx str = - match str with - | 0 -> Ok `type_ - | 1 -> Ok `value - | 2 -> Ok `rank - | 3 -> Ok `keywords - | 4 -> Ok `credits - | 5 -> Ok `updated_at - | 6 -> Ok `commisioned - | 7 -> Ok `name - | _ -> Error `invalid_tag in - Visitor.make ~visit_string ~visit_int () in - let name = ref None in - let commisioned = ref None in - let updated_at = ref None in - let credits = ref None in - let keywords = ref None in - let rank = ref None in - let value = ref None in - let type_ = ref None in - let rec read_fields () = - let* tag = next_field ctx field_visitor - in - match tag with - | Some `type_ -> - let* v = field ctx "type" string - in (type_ := (Some v); read_fields ()) - | Some `value -> - let* v = field ctx "value" float - in (value := (Some v); read_fields ()) - | Some `rank -> - let* v = field ctx "rank" (d deserialize_rank) - in (rank := (Some v); read_fields ()) - | Some `keywords -> - let* v = field ctx "keywords" (d (array string)) - in (keywords := (Some v); read_fields ()) - | Some `credits -> - let* v = field ctx "credits" (d (option int32)) - in (credits := (Some v); read_fields ()) - | Some `updated_at -> - let* v = field ctx "updated_at" int64 - in (updated_at := (Some v); read_fields ()) - | Some `commisioned -> - let* v = field ctx "commisioned" bool - in (commisioned := (Some v); read_fields ()) - | Some `name -> - let* v = field ctx "name" string - in (name := (Some v); read_fields ()) - | None -> Ok () in - let* () = read_fields () - in - let* name = - Option.to_result - ~none:(`Msg "missing field \"name\" (\"name\")") ( - !name) - in - let* commisioned = - Option.to_result - ~none:(`Msg - "missing field \"commisioned\" (\"commisioned\")") - (!commisioned) - in - let* updated_at = - Option.to_result - ~none:(`Msg - "missing field \"updated_at\" (\"updated_at\")") - (!updated_at) - in - let credits = - match !credits with | Some opt -> opt | None -> None in - let* keywords = - Option.to_result - ~none:(`Msg "missing field \"keywords\" (\"keywords\")") - (!keywords) - in - let* rank = - Option.to_result - ~none:(`Msg "missing field \"rank\" (\"rank\")") ( - !rank) - in - let* value = - Option.to_result - ~none:(`Msg "missing field \"value\" (\"value\")") - (!value) - in - let* type_ = - Option.to_result - ~none:(`Msg "missing field \"type\" (\"type_\")") ( - !type_) - in - Ok - { - type_; - value; - rank; - keywords; - credits; - updated_at; - commisioned; - name - }) - let _ = deserialize_t - end[@@ocaml.doc "@inline"][@@merlin.hide ] - type t_list = { - stuff: t list }[@@deriving (serialize, deserialize)] - include - struct - let _ = fun (_ : t_list) -> () - let ( let* ) = Result.bind - let _ = ( let* ) - let serialize_t_list = - let open Serde.Ser in - fun t -> - fun ctx -> - record ctx "t_list" 1 - (fun ctx -> - let* () = - field ctx "stuff" ((s (list (s serialize_t))) t.stuff) - in Ok ()) - let _ = serialize_t_list - open! Serde - let ( let* ) = Result.bind - let _ = ( let* ) - let deserialize_t_list = - let ( let* ) = Result.bind in - let open Serde.De in - fun ctx -> - record ctx "t_list" 1 - (fun ctx -> - let field_visitor = - let visit_string _ctx str = - match str with - | "stuff" -> Ok `stuff - | _ -> Error `invalid_tag in - let visit_int _ctx str = - match str with | 0 -> Ok `stuff | _ -> Error `invalid_tag in - Visitor.make ~visit_string ~visit_int () in - let stuff = ref None in - let rec read_fields () = - let* tag = next_field ctx field_visitor - in - match tag with - | Some `stuff -> - let* v = field ctx "stuff" (d (list (d deserialize_t))) - in (stuff := (Some v); read_fields ()) - | None -> Ok () in - let* () = read_fields () - in - let* stuff = - Option.to_result - ~none:(`Msg "missing field \"stuff\" (\"stuff\")") - (!stuff) - in Ok { stuff }) - let _ = deserialize_t_list - end[@@ocaml.doc "@inline"][@@merlin.hide ] - let () = - let test_t = - { - stuff = - [{ - name = "hello"; - commisioned = false; - updated_at = 9223372036854766L; - credits = None; - keywords = [||]; - rank = { rank_name = "asdf"; rank_scores = ["1"; "c"; "a"] }; - value = 420.69; - type_ = "something" - }; - { - name = "hello"; - commisioned = false; - updated_at = 0L; - credits = (Some 2112l); - keywords = [|"hello"|]; - rank = { rank_name = "asdf"; rank_scores = [] }; - value = Float.pi; - type_ = "something" - }] - } in - let json1 = (Serde_json.to_string serialize_t_list test_t) |> Result.get_ok in - let value = - (Serde_json.of_string deserialize_t_list json1) |> Result.get_ok in - let json2 = (Serde_json.to_string serialize_t_list value) |> Result.get_ok in - Format.printf "[%s,%s]\n%!" json1 json2 - - - - -Now we test the variants: - - $ dune exec ./variant_test.exe | jq . - [ - { - "Ranks": [ - "Ensign", - { - "Commander": [ - "riker", - 2112, - 3.14159265359 - ] - }, - { - "Lt": null - }, - { - "Lt": false - }, - { - "Lt": true - }, - { - "Captain": { - "name": "janeway", - "ship": "voyager" - } - } - ] - }, - { - "Ranks": [ - "Ensign", - { - "Commander": [ - "riker", - 2112, - 3.14159265359 - ] - }, - { - "Lt": null - }, - { - "Lt": false - }, - { - "Lt": true - }, - { - "Captain": { - "name": "janeway", - "ship": "voyager" - } - } - ] - } - ] - $ dune describe pp ./variant_test.ml - [@@@ocaml.ppx.context - { - tool_name = "ppx_driver"; - include_dirs = []; - load_path = []; - open_modules = []; - for_package = None; - debug = false; - use_threads = false; - use_vmthreads = false; - recursive_types = false; - principal = false; - transparent_modules = false; - unboxed_types = false; - unsafe_string = false; - cookies = [] - }] - [@@@warning "-37"] - type rank = - | Captain of { - name: string ; - ship: string } - | Commander of string * int32 * float - | Lt of bool option - | Ensign [@@deriving (serialize, deserialize)] - include - struct - let _ = fun (_ : rank) -> () - let ( let* ) = Result.bind - let _ = ( let* ) - let serialize_rank = - let open Serde.Ser in - fun t -> - fun ctx -> - match t with - | Captain r -> - record_variant ctx "rank" 0 "Captain" 2 - (fun ctx -> - let* () = field ctx "name" (string r.name) - in let* () = field ctx "ship" (string r.ship) - in Ok ()) - | Commander (v_1, v_2, v_3) -> - tuple_variant ctx "rank" 1 "Commander" 3 - (fun ctx -> - let* () = element ctx (string v_1) - in - let* () = element ctx (int32 v_2) - in let* () = element ctx (float v_3) - in Ok ()) - | Lt v_1 -> - newtype_variant ctx "rank" 2 "Lt" ((s (option bool)) v_1) - | Ensign -> unit_variant ctx "rank" 3 "Ensign" - let _ = serialize_rank - open! Serde - let ( let* ) = Result.bind - let _ = ( let* ) - let deserialize_rank = - let ( let* ) = Result.bind in - let open Serde.De in - fun ctx -> - let field_visitor = - Visitor.make - ~visit_string:(fun _ctx -> - fun str -> - match str with - | "Captain" -> Ok `Captain - | "Commander" -> Ok `Commander - | "Lt" -> Ok `Lt - | "Ensign" -> Ok `Ensign - | _ -> Error `invalid_tag) () in - (variant ctx "rank" ["Captain"; "Commander"; "Lt"; "Ensign"]) @@ - (fun ctx -> - let* tag = identifier ctx field_visitor - in - match tag with - | `Captain -> - record_variant ctx 2 - (fun ~size -> - fun ctx -> - ignore size; - (let field_visitor = - let visit_string _ctx str = - match str with - | "ship" -> Ok `ship - | "name" -> Ok `name - | _ -> Error `invalid_tag in - let visit_int _ctx str = - match str with - | 0 -> Ok `ship - | 1 -> Ok `name - | _ -> Error `invalid_tag in - Visitor.make ~visit_string ~visit_int () in - let name = ref None in - let ship = ref None in - let rec read_fields () = - let* tag = next_field ctx field_visitor - in - match tag with - | Some `ship -> - let* v = field ctx "ship" string - in (ship := (Some v); read_fields ()) - | Some `name -> - let* v = field ctx "name" string - in (name := (Some v); read_fields ()) - | None -> Ok () in - let* () = read_fields () - in - let* name = - Option.to_result - ~none:(`Msg - "missing field \"name\" (\"name\")") - (!name) - in - let* ship = - Option.to_result - ~none:(`Msg - "missing field \"ship\" (\"ship\")") - (!ship) - in Ok (Captain { ship; name }))) - | `Commander -> - tuple_variant ctx 3 - (fun ~size -> - fun ctx -> - ignore size; - (let* v_1 = - match element ctx string with - | Ok (Some v) -> Ok v - | Ok (None) -> Error `no_more_data - | Error reason -> Error reason - in - let* v_2 = - match element ctx int32 with - | Ok (Some v) -> Ok v - | Ok (None) -> Error `no_more_data - | Error reason -> Error reason - in - let* v_3 = - match element ctx float with - | Ok (Some v) -> Ok v - | Ok (None) -> Error `no_more_data - | Error reason -> Error reason - in Ok (Commander (v_1, v_2, v_3)))) - | `Lt -> - (newtype_variant ctx) @@ - ((fun ctx -> - let* v_1 = (d (option bool)) ctx - in Ok (Lt v_1))) - | `Ensign -> let* () = unit_variant ctx - in Ok Ensign) - let _ = deserialize_rank - end[@@ocaml.doc "@inline"][@@merlin.hide ] - type ranks = - | Ranks of rank list [@@deriving (serialize, deserialize)] - include - struct - let _ = fun (_ : ranks) -> () - let ( let* ) = Result.bind - let _ = ( let* ) - let serialize_ranks = - let open Serde.Ser in - fun t -> - fun ctx -> - match t with - | Ranks v_1 -> - newtype_variant ctx "ranks" 0 "Ranks" - ((s (list (s serialize_rank))) v_1) - let _ = serialize_ranks - open! Serde - let ( let* ) = Result.bind - let _ = ( let* ) - let deserialize_ranks = - let ( let* ) = Result.bind in - let open Serde.De in - fun ctx -> - let field_visitor = - Visitor.make - ~visit_string:(fun _ctx -> - fun str -> - match str with - | "Ranks" -> Ok `Ranks - | _ -> Error `invalid_tag) () in - (variant ctx "ranks" ["Ranks"]) @@ - (fun ctx -> - let* tag = identifier ctx field_visitor - in - match tag with - | `Ranks -> - (newtype_variant ctx) @@ - ((fun ctx -> - let* v_1 = (d (list (d deserialize_rank))) ctx - in Ok (Ranks v_1)))) - let _ = deserialize_ranks - end[@@ocaml.doc "@inline"][@@merlin.hide ] - let () = - let test_t = - Ranks - [Ensign; - Commander ("riker", 2112l, Float.pi); - Lt None; - Lt (Some false); - Lt (Some true); - Captain { name = "janeway"; ship = "voyager" }] in - let json1 = (Serde_json.to_string serialize_ranks test_t) |> Result.get_ok in - let value = (Serde_json.of_string deserialize_ranks json1) |> Result.get_ok in - let json2 = (Serde_json.to_string serialize_ranks value) |> Result.get_ok in - Format.printf "[%s,%s]\n%!" json1 json2 diff --git a/derive/ppx.t/variant_test.ml b/derive/ppx.t/variant_test.ml deleted file mode 100644 index 1525360..0000000 --- a/derive/ppx.t/variant_test.ml +++ /dev/null @@ -1,28 +0,0 @@ -[@@@warning "-37"] - -type rank = - | Captain of { name : string; ship : string } - | Commander of string * int32 * float - | Lt of bool option - | Ensign -[@@deriving serialize, deserialize] - -type ranks = Ranks of rank list [@@deriving serialize, deserialize] - -let () = - let test_t = - Ranks - [ - Ensign; - Commander ("riker", 2112l, Float.pi); - Lt None; - Lt (Some false); - Lt (Some true); - Captain { name = "janeway"; ship = "voyager" }; - ] - in - let json1 = Serde_json.to_string serialize_ranks test_t |> Result.get_ok in - (* Format.printf "%s\n%!" json1 *) - let value = Serde_json.of_string deserialize_ranks json1 |> Result.get_ok in - let json2 = Serde_json.to_string serialize_ranks value |> Result.get_ok in - Format.printf "[%s,%s]\n%!" json1 json2 diff --git a/derive/ser.ml b/derive/ser.ml deleted file mode 100644 index 47cff7c..0000000 --- a/derive/ser.ml +++ /dev/null @@ -1,227 +0,0 @@ -open Ppxlib -module Ast = Ast_builder.Default - -(** helpers *) -let loc ~ctxt = Expansion_context.Deriver.derived_item_loc ctxt - -let var ~ctxt name = - let loc = loc ~ctxt in - Loc.make ~loc name - -let gensym () = - let counter = ref 0 in - fun ~ctxt -> - counter := !counter + 1; - var ~ctxt ("v_" ^ Int.to_string !counter) - -let serializer_fn_name_for_longident name = - let name = - match name.txt |> Longident.flatten_exn |> List.rev with - | name :: [] -> "serialize_" ^ name - | name :: path -> - ("serialize_" ^ name) :: path |> List.rev |> String.concat "." - | _ -> "unknown" - in - Longident.parse name - -let is_primitive = function - | "bool" | "char" | "float" | "int" | "int32" | "int64" | "string" | "list" - | "array" | "unit" | "option" -> - true - | _ -> false - -let rec serializer_for_type ~ctxt (core_type : Parsetree.core_type) = - let loc = loc ~ctxt in - match core_type.ptyp_desc with - | Ptyp_constr (name, arg :: []) when is_primitive (Longident.name name.txt) -> - let type_ser = serializer_for_type ~ctxt arg in - let name = Ast.pexp_ident ~loc name in - [%expr s ([%e name] [%e type_ser])] - | Ptyp_constr (name, []) when is_primitive (Longident.name name.txt) -> - Ast.pexp_ident ~loc name - | Ptyp_constr (name, _args) -> - let ser_fn = - serializer_fn_name_for_longident name - |> var ~ctxt |> Ast.pexp_ident ~loc - in - [%expr s [%e ser_fn]] - | Ptyp_any | Ptyp_var _ - | Ptyp_arrow (_, _, _) - | Ptyp_tuple _ - | Ptyp_object (_, _) - | Ptyp_class (_, _) - | Ptyp_alias (_, _) - | Ptyp_variant (_, _, _) - | Ptyp_poly (_, _) - | Ptyp_package _ | Ptyp_extension _ -> - failwith "unsupported" - -(** implementation *) - -let gen_serialize_variant_impl ~ctxt ptype_name cstr_declarations = - let loc = loc ~ctxt in - let type_name = Ast.estring ~loc ptype_name.txt in - - let pattern_of_constructor cstr = - match cstr.pcd_args with - | Pcstr_tuple [] -> None - | Pcstr_tuple parts -> - let gensym = gensym () in - Some - (Ast.ppat_tuple ~loc - (List.map (fun _ -> Ast.pvar ~loc (gensym ~ctxt).txt) parts)) - | Pcstr_record _ -> Some (Ast.pvar ~loc "r") - in - - let ser_by_constructor type_name idx cstr = - let idx = Ast.eint ~loc idx in - let name = Ast.estring ~loc cstr.pcd_name.txt in - match cstr.pcd_args with - | Pcstr_tuple [] -> - [%expr unit_variant ctx [%e type_name] [%e idx] [%e name]] - | Pcstr_tuple [ arg ] -> - let ser_fn = serializer_for_type ~ctxt arg in - let arg_var = Ast.evar ~loc (gensym () ~ctxt).txt in - let ser = [%expr [%e ser_fn] [%e arg_var]] in - [%expr newtype_variant ctx [%e type_name] [%e idx] [%e name] [%e ser]] - | Pcstr_tuple args -> - let arg_count = Ast.eint ~loc (List.length args) in - let gensym = gensym () in - let calls = - List.mapi - (fun _idx arg -> - let ser_fn = serializer_for_type ~ctxt arg in - let arg_var = Ast.evar ~loc (gensym ~ctxt).txt in - [%expr element ctx ([%e ser_fn] [%e arg_var])]) - args - in - - let calls = - List.fold_left - (fun last expr -> - [%expr - let* () = [%e expr] in - [%e last]]) - [%expr Ok ()] (List.rev calls) - in - [%expr - tuple_variant ctx [%e type_name] [%e idx] [%e name] [%e arg_count] - (fun ctx -> [%e calls])] - | Pcstr_record labels -> - let field_count = Ast.eint ~loc (List.length labels) in - let labels = List.rev labels in - let labels = List.map Attributes.of_field_attributes labels in - let fields = - List.map - (fun (field, attr) -> - let field_name = Ast.estring ~loc Attributes.(attr.name) in - let field_access = - let field_name = Longident.parse field.pld_name.txt in - Ast.pexp_field ~loc (Ast.evar ~loc "r") - (Loc.make ~loc field_name) - in - let serializer = serializer_for_type ~ctxt field.pld_type in - [%expr - field ctx [%e field_name] ([%e serializer] [%e field_access])]) - labels - in - let fields = - List.fold_left - (fun last curr -> - [%expr - let* () = [%e curr] in - [%e last]]) - [%expr Ok ()] fields - in - - [%expr - record_variant ctx [%e type_name] [%e idx] [%e name] [%e field_count] - (fun ctx -> [%e fields])] - in - - let cases = - List.mapi - (fun idx (cstr : Parsetree.constructor_declaration) -> - let lhs = Ast.pconstruct cstr (pattern_of_constructor cstr) in - let rhs = ser_by_constructor type_name idx cstr in - Ast.case ~lhs ~guard:None ~rhs) - cstr_declarations - in - - Ast.pexp_match ~loc [%expr t] cases - -let gen_serialize_record_impl ~ctxt ptype_name label_declarations = - let loc = loc ~ctxt in - let type_name = Ast.estring ~loc ptype_name.txt in - let field_count = Ast.eint ~loc (List.length label_declarations) in - let labels = List.rev label_declarations in - let labels = List.map Attributes.of_field_attributes labels in - - let fields = - List.map - (fun (field, attr) -> - let field_name = Ast.estring ~loc Attributes.(attr.name) in - let field_access = - let field_name = Longident.parse field.pld_name.txt in - Ast.pexp_field ~loc (Ast.evar ~loc "t") (Loc.make ~loc field_name) - in - let serializer = serializer_for_type ~ctxt field.pld_type in - [%expr field ctx [%e field_name] ([%e serializer] [%e field_access])]) - labels - in - - let fields = - List.fold_left - (fun last curr -> - [%expr - let* () = [%e curr] in - [%e last]]) - [%expr Ok ()] fields - in - - [%expr record ctx [%e type_name] [%e field_count] (fun ctx -> [%e fields])] - -let gen_serialize_impl ~ctxt type_decl = - let loc = loc ~ctxt in - - let typename = type_decl.ptype_name.txt in - - let body = - match type_decl with - | { ptype_kind = Ptype_record label_declarations; ptype_name; _ } -> - gen_serialize_record_impl ~ctxt ptype_name label_declarations - | { ptype_kind = Ptype_variant cstrs_declaration; ptype_name; _ } -> - gen_serialize_variant_impl ~ctxt ptype_name cstrs_declaration - | { ptype_kind; ptype_name; _ } -> - let err = - match ptype_kind with - | Ptype_abstract -> "unsupported abstract type" - | Ptype_variant _ -> "unsupported variant type" - | Ptype_record _ -> "unsupported record type" - | Ptype_open -> "unsupported open type" - in - [%expr - [%e ptype_name.txt |> Ast.estring ~loc] [%e err |> Ast.estring ~loc]] - in - let serializer_name = - "serialize_" ^ typename |> var ~ctxt |> Ast.ppat_var ~loc - in - [%stri let [%p serializer_name] = Serde.Ser.(fun t ctx -> [%e body])] - -let generate_impl ~ctxt (_rec_flag, type_declarations) = - let loc = loc ~ctxt in - [ [%stri let ( let* ) = Result.bind] ] - @ List.map (gen_serialize_impl ~ctxt) type_declarations - -let impl_generator = Deriving.Generator.V2.make_noarg generate_impl - -(** interface *) - -let generate_intf ~ctxt:_ (_rec_flag, _type_declarations) = [] -let intf_generator = Deriving.Generator.V2.make_noarg generate_intf - -(** registration *) - -let register = - Deriving.add "serialize" ~str_type_decl:impl_generator - ~sig_type_decl:intf_generator diff --git a/dune-project b/dune-project index 8419cff..3d0725d 100644 --- a/dune-project +++ b/dune-project @@ -1,12 +1,12 @@ (lang dune 3.13) (cram enable) -(name serde) +(name serde_json) (generate_opam_files true) (source - (github serde-ml/serde)) + (github serde-ml/json)) (authors "Leandro Ostera ") @@ -14,30 +14,6 @@ (license "MIT") -(package - (name serde) - (synopsis "A serialization framework for OCaml") - (description "Serde is a serialization framework for OCaml that runs on the principle of maximum efficiency and user ergonomics while maintaining format flexibility.") - (depends - (ocaml (>= "5.1.1")) - (qcheck :with-test) - (rio (>= "0.0.8")) - (spices :with-test) - dune)) - - -(package - (name serde_derive) - (synopsis "Derive-macros for the Serde serialization framework") - (description "These macros help derive serializers and deserializers for your existing types and provide all the functionality you expect to plug in different data-formats.") - (depends - (ocaml (>= "5.1.1")) - (ppx_deriving (>= "5.2.1")) - (ppxlib (>= "0.28.0")) - (serde (= :version)) - dune)) - - (package (name serde_json) (synopsis "JSON format support for Serde") diff --git a/examples/dune b/examples/dune deleted file mode 100644 index f53c4a5..0000000 --- a/examples/dune +++ /dev/null @@ -1,5 +0,0 @@ -(executable - (name starfleet) - (preprocess - (pps serde_derive)) - (libraries serde serde_json)) diff --git a/examples/starfleet.ml b/examples/starfleet.ml deleted file mode 100644 index 37a4060..0000000 --- a/examples/starfleet.ml +++ /dev/null @@ -1,32 +0,0 @@ -(* type rank = Captain | Chief_petty_officer *) -(* type t = { name : string; rank : rank } *) - -(* let obrien = { name = "Miles O'Brien"; rank = Chief_petty_officer } *) -(* let sisko = { name = "Benjamin Sisko"; rank = Captain } *) - -type rank = { rank_name : string; rank_scores : string list } -[@@deriving serialize] - -type t = { - name : string; - commisioned : bool; - updated_at : int64; - credits : int32 option; - keywords : string array; - rank : rank; -} -[@@deriving serialize] - -let () = - let test_t = - { - name = "hello"; - commisioned = false; - updated_at = Int64.(sub max_int 1L); - credits = None; - keywords = [||]; - rank = { rank_name = "asdf"; rank_scores = [ "1"; "c"; "a" ] }; - } - in - let json = Serde_json.to_string serialize_t test_t |> Result.get_ok in - Format.printf "%s\n%!" json diff --git a/serde.opam b/serde.opam deleted file mode 100644 index bfd9314..0000000 --- a/serde.opam +++ /dev/null @@ -1,33 +0,0 @@ -# This file is generated by dune, edit dune-project instead -opam-version: "2.0" -synopsis: "A serialization framework for OCaml" -description: - "Serde is a serialization framework for OCaml that runs on the principle of maximum efficiency and user ergonomics while maintaining format flexibility." -maintainer: ["Leandro Ostera "] -authors: ["Leandro Ostera "] -license: "MIT" -homepage: "https://github.com/serde-ml/serde" -bug-reports: "https://github.com/serde-ml/serde/issues" -depends: [ - "ocaml" {>= "5.1.1"} - "qcheck" {with-test} - "rio" {>= "0.0.8"} - "spices" {with-test} - "dune" {>= "3.13"} - "odoc" {with-doc} -] -build: [ - ["dune" "subst"] {dev} - [ - "dune" - "build" - "-p" - name - "-j" - jobs - "@install" - "@runtest" {with-test} - "@doc" {with-doc} - ] -] -dev-repo: "git+https://github.com/serde-ml/serde.git" diff --git a/serde/dune b/serde/dune deleted file mode 100644 index 4074b7e..0000000 --- a/serde/dune +++ /dev/null @@ -1,10 +0,0 @@ -(library - (public_name serde) - (modules serde) - (libraries rio)) - -(test - (package serde) - (name serde_test) - (modules serde_test) - (libraries serde qcheck spices)) diff --git a/serde/serde.ml b/serde/serde.ml deleted file mode 100644 index d869278..0000000 --- a/serde/serde.ml +++ /dev/null @@ -1,764 +0,0 @@ -let ( let* ) = Result.bind - -let pp_list pp_el fmt t = - Format.fprintf fmt "["; - Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt "; ") - pp_el fmt t; - Format.fprintf fmt "]" - -type error = - [ `invalid_field_type - | `missing_field - | `no_more_data - | `unimplemented - | `invalid_tag - | `Msg of string - | Rio.io_error ] - -let pp_err fmt t = - match t with - | `invalid_field_type -> Format.fprintf fmt "invalid_field_type" - | `missing_field -> Format.fprintf fmt "missing_field" - | `no_more_data -> Format.fprintf fmt "no_more_data" - | `unimplemented -> Format.fprintf fmt "unimplemented" - | `invalid_tag -> Format.fprintf fmt "invalid_tag" - | `Msg str -> Format.fprintf fmt "%S" str - | #Rio.io_error as err -> Rio.pp_err fmt err - -module Config = struct - type t = { camelcase_fields : bool } - - let default = { camelcase_fields = false } -end - -module rec Ser_base : sig - type ('value, 'state, 'output) t = - 'value -> ('value, 'state, 'output) ctx -> ('output, error) result - - and ('value, 'state, 'output) ctx = - | Ctx of - ('value, 'state, 'output) t - * ('state, 'output) Ser_base.serializer - * 'state - - val serializer : ('value, 'state, 'output) t -> ('value, 'state, 'output) t - - module type Serializer = sig - type output - type state - - val nest : state -> state - - val serialize_bool : - ('value, state, output) ctx -> state -> bool -> (output, error) result - - val serialize_int8 : - ('value, state, output) ctx -> state -> char -> (output, error) result - - val serialize_int16 : - ('value, state, output) ctx -> state -> int -> (output, error) result - - val serialize_int31 : - ('value, state, output) ctx -> state -> int -> (output, error) result - - val serialize_int32 : - ('value, state, output) ctx -> state -> int32 -> (output, error) result - - val serialize_int64 : - ('value, state, output) ctx -> state -> int64 -> (output, error) result - - val serialize_float : - ('value, state, output) ctx -> state -> float -> (output, error) result - - val serialize_string : - ('value, state, output) ctx -> state -> string -> (output, error) result - - val serialize_none : - ('value, state, output) ctx -> state -> (output, error) result - - val serialize_some : - ('value, state, output) ctx -> - state -> - (('value, state, output) ctx -> (output, error) result) -> - (output, error) result - - val serialize_sequence : - ('value, state, output) ctx -> - state -> - size:int -> - (('value, state, output) ctx -> (output, error) result) -> - (output, error) result - - val serialize_element : - ('value, state, output) ctx -> - state -> - (('value, state, output) ctx -> (output, error) result) -> - (output, error) result - - val serialize_unit_variant : - ('value, state, output) ctx -> - state -> - var_type:string -> - cstr_idx:int -> - cstr_name:string -> - (output, error) result - - val serialize_newtype_variant : - ('value, state, output) ctx -> - state -> - var_type:string -> - cstr_idx:int -> - cstr_name:string -> - (('value, state, output) ctx -> (output, error) result) -> - (output, error) result - - val serialize_tuple_variant : - ('value, state, output) ctx -> - state -> - var_type:string -> - cstr_idx:int -> - cstr_name:string -> - size:int -> - (('value, state, output) ctx -> (output, error) result) -> - (output, error) result - - val serialize_record_variant : - ('value, state, output) ctx -> - state -> - var_type:string -> - cstr_idx:int -> - cstr_name:string -> - size:int -> - (('value, state, output) ctx -> (output, error) result) -> - (output, error) result - - val serialize_record : - ('value, state, output) ctx -> - state -> - rec_type:string -> - size:int -> - (('value, state, output) ctx -> (output, error) result) -> - (output, error) result - - val serialize_field : - ('value, state, output) ctx -> - state -> - name:string -> - (('value, state, output) ctx -> (output, error) result) -> - (output, error) result - end - - type ('state, 'output) serializer = - (module Serializer with type output = 'output and type state = 'state) -end = struct - type ('value, 'state, 'output) t = - 'value -> ('value, 'state, 'output) ctx -> ('output, error) result - - and ('value, 'state, 'output) ctx = - | Ctx of - ('value, 'state, 'output) t - * ('state, 'output) Ser_base.serializer - * 'state - - let serializer fn = fn - - module type Serializer = sig - type output - type state - - val nest : state -> state - - val serialize_bool : - ('value, state, output) ctx -> state -> bool -> (output, error) result - - val serialize_int8 : - ('value, state, output) ctx -> state -> char -> (output, error) result - - val serialize_int16 : - ('value, state, output) ctx -> state -> int -> (output, error) result - - val serialize_int31 : - ('value, state, output) ctx -> state -> int -> (output, error) result - - val serialize_int32 : - ('value, state, output) ctx -> state -> int32 -> (output, error) result - - val serialize_int64 : - ('value, state, output) ctx -> state -> int64 -> (output, error) result - - val serialize_float : - ('value, state, output) ctx -> state -> float -> (output, error) result - - val serialize_string : - ('value, state, output) ctx -> state -> string -> (output, error) result - - val serialize_none : - ('value, state, output) ctx -> state -> (output, error) result - - val serialize_some : - ('value, state, output) ctx -> - state -> - (('value, state, output) ctx -> (output, error) result) -> - (output, error) result - - val serialize_sequence : - ('value, state, output) ctx -> - state -> - size:int -> - (('value, state, output) ctx -> (output, error) result) -> - (output, error) result - - val serialize_element : - ('value, state, output) ctx -> - state -> - (('value, state, output) ctx -> (output, error) result) -> - (output, error) result - - val serialize_unit_variant : - ('value, state, output) ctx -> - state -> - var_type:string -> - cstr_idx:int -> - cstr_name:string -> - (output, error) result - - val serialize_newtype_variant : - ('value, state, output) ctx -> - state -> - var_type:string -> - cstr_idx:int -> - cstr_name:string -> - (('value, state, output) ctx -> (output, error) result) -> - (output, error) result - - val serialize_tuple_variant : - ('value, state, output) ctx -> - state -> - var_type:string -> - cstr_idx:int -> - cstr_name:string -> - size:int -> - (('value, state, output) ctx -> (output, error) result) -> - (output, error) result - - val serialize_record_variant : - ('value, state, output) ctx -> - state -> - var_type:string -> - cstr_idx:int -> - cstr_name:string -> - size:int -> - (('value, state, output) ctx -> (output, error) result) -> - (output, error) result - - val serialize_record : - ('value, state, output) ctx -> - state -> - rec_type:string -> - size:int -> - (('value, state, output) ctx -> (output, error) result) -> - (output, error) result - - val serialize_field : - ('value, state, output) ctx -> - state -> - name:string -> - (('value, state, output) ctx -> (output, error) result) -> - (output, error) result - end - - type ('state, 'output) serializer = - (module Serializer with type output = 'output and type state = 'state) -end - -module Ser = struct - include Ser_base - - let serialize (type value state output) (ctx : (value, state, output) ctx) - (ser : (value, state, output) ctx -> (output, error) result) : - (output, error) result = - ser ctx - - let serialize_sequence (type value state output) - (Ctx (_, (module S), state) as self : (value, state, output) ctx) size - elements = - S.serialize_sequence self state ~size elements - - let serialize_record (type value state output) - (Ctx (_, (module S), state) as self : (value, state, output) ctx) rec_type - size fields = - S.serialize_record self state ~rec_type ~size fields - - let sequence (type value state output) - (Ctx (_, (module S), state) as self : (value, state, output) ctx) size - elements = - S.serialize_sequence self state ~size elements - - let unit_variant (type value state output) - (Ctx (_, (module S), state) as self : (value, state, output) ctx) var_type - cstr_idx cstr_name = - S.serialize_unit_variant self state ~var_type ~cstr_idx ~cstr_name - - let newtype_variant (type value state output) - (Ctx (_, (module S), state) as self : (value, state, output) ctx) var_type - cstr_idx cstr_name value = - S.serialize_newtype_variant self state ~var_type ~cstr_idx ~cstr_name value - - let tuple_variant (type value state output) - (Ctx (_, (module S), state) as ctx : (value, state, output) ctx) var_type - cstr_idx cstr_name size = - S.serialize_tuple_variant ctx state ~var_type ~cstr_idx ~cstr_name ~size - - let record_variant (type value state output) - (Ctx (_, (module S), state) as ctx : (value, state, output) ctx) var_type - cstr_idx cstr_name size = - S.serialize_record_variant ctx state ~var_type ~cstr_idx ~cstr_name ~size - - let record (type value state output) - (Ctx (_, (module S), state) as ctx : (value, state, output) ctx) rec_type - size = - S.serialize_record ctx state ~rec_type ~size - - let element (type value state output) - (Ctx (_, (module S), state) as ctx : (value, state, output) ctx) value = - S.serialize_element ctx state value - - let field (type value state output) - (Ctx (_, (module S), state) as ctx : (value, state, output) ctx) name - value = - S.serialize_field ctx state ~name value - - let bool (type value state output) bool - (Ctx (_, (module S), state) as self : (value, state, output) ctx) = - S.serialize_bool self state bool - - let serialize_int8 (type value state output) int - (Ctx (_, (module S), state) as self : (value, state, output) ctx) = - S.serialize_int8 self state int - - let serialize_int16 (type value state output) int - (Ctx (_, (module S), state) as self : (value, state, output) ctx) = - S.serialize_int16 self state int - - let serialize_int31 (type value state output) int - (Ctx (_, (module S), state) as self : (value, state, output) ctx) = - S.serialize_int31 self state int - - let serialize_int32 (type value state output) int - (Ctx (_, (module S), state) as self : (value, state, output) ctx) = - S.serialize_int32 self state int - - let serialize_int64 (type value state output) int - (Ctx (_, (module S), state) as self : (value, state, output) ctx) = - S.serialize_int64 self state int - - let serialize_float (type value state output) float - (Ctx (_, (module S), state) as self : (value, state, output) ctx) = - S.serialize_float self state float - - let int int ctx = serialize_int31 int ctx - let int8 int ctx = serialize_int8 int ctx - let int16 int ctx = serialize_int16 int ctx - let int32 int ctx = serialize_int32 int ctx - let int64 int ctx = serialize_int64 int ctx - let float float ctx = serialize_float float ctx - - let string (type value state output) string - (Ctx (_, (module S), state) as self : (value, state, output) ctx) = - S.serialize_string self state string - - let option (type value state output) ser value - (Ctx (_, (module S), state) as self : (value, state, output) ctx) = - match value with - | None -> S.serialize_none self state - | Some s -> S.serialize_some self state (fun ctx -> ser s ctx) - - let list ser values ctx = - sequence ctx (List.length values) @@ fun ctx -> - List.fold_left - (fun acc el -> match acc with Ok () -> element ctx (ser el) | _ -> acc) - (Ok ()) values - - let array ser values ctx = list ser (Array.to_list values) ctx - - let s : - type value value2 state output. - (value, state, output) t -> - value -> - (value2, state, output) ctx -> - (output, error) result = - fun ser value (Ctx (_self, (module S), state)) -> - let state = S.nest state in - ser value (Ctx (ser, (module S), state)) -end - -module rec De_base : sig - type ('value, 'state) t = 'state De_base.ctx -> ('value, error) result - and 'state ctx = 'state De_base.deserializer * 'state - - type ('value, 'state, 'tag) visitor = { - visit_int : 'state De_base.ctx -> int -> ('value, error) result; - visit_string : 'state De_base.ctx -> string -> ('value, error) result; - visit_variant : 'state De_base.ctx -> ('value, error) result; - } - - val deserializer : - ('state De_base.ctx -> ('value, error) result) -> ('value, 'state) t - - module type Deserializer = sig - type state - - val nest : state -> state - - val deserialize_sequence : - state ctx -> - state -> - size:int -> - (size:int -> ('value, state) t) -> - ('value, error) result - - val deserialize_element : - state ctx -> state -> ('value, state) t -> ('value option, error) result - - val deserialize_variant : - state ctx -> - state -> - ('value, state, 'tag) visitor -> - name:string -> - variants:string list -> - ('value, error) result - - val deserialize_unit_variant : state ctx -> state -> (unit, error) result - - val deserialize_newtype_variant : - state ctx -> state -> ('value, state) t -> ('value, error) result - - val deserialize_tuple_variant : - state ctx -> - state -> - size:int -> - (size:int -> ('value, state) t) -> - ('value, error) result - - val deserialize_record_variant : - state ctx -> - state -> - size:int -> - (size:int -> ('value, state) t) -> - ('value, error) result - - val deserialize_record : - state ctx -> - state -> - name:string -> - size:int -> - ('value, state) t -> - ('value, error) result - - val deserialize_field : - state ctx -> - state -> - name:string -> - ('value, state) t -> - ('value, error) result - - val deserialize_key : - state ctx -> - state -> - ('value, state, 'tag) visitor -> - ('value option, error) result - - val deserialize_identifier : - state ctx -> - state -> - ('value, state, 'tag) visitor -> - ('value, error) result - - val deserialize_string : state ctx -> state -> (string, error) result - val deserialize_int8 : state ctx -> state -> (char, error) result - val deserialize_int16 : state ctx -> state -> (int, error) result - val deserialize_int31 : state ctx -> state -> (int, error) result - val deserialize_int32 : state ctx -> state -> (int32, error) result - val deserialize_int64 : state ctx -> state -> (int64, error) result - val deserialize_bool : state ctx -> state -> (bool, error) result - val deserialize_float : state ctx -> state -> (float, error) result - - val deserialize_option : - state ctx -> state -> ('value, state) t -> ('value option, error) result - end - - type 'state deserializer = (module Deserializer with type state = 'state) -end = struct - type ('value, 'state) t = 'state De_base.ctx -> ('value, error) result - and 'state ctx = 'state De_base.deserializer * 'state - - type ('value, 'state, 'tag) visitor = { - visit_int : 'state De_base.ctx -> int -> ('value, error) result; - visit_string : 'state De_base.ctx -> string -> ('value, error) result; - visit_variant : 'state De_base.ctx -> ('value, error) result; - } - - let deserializer fn = fn - - module type Deserializer = sig - type state - - val nest : state -> state - - val deserialize_sequence : - state ctx -> - state -> - size:int -> - (size:int -> ('value, state) t) -> - ('value, error) result - - val deserialize_element : - state ctx -> state -> ('value, state) t -> ('value option, error) result - - val deserialize_variant : - state ctx -> - state -> - ('value, state, 'tag) visitor -> - name:string -> - variants:string list -> - ('value, error) result - - val deserialize_unit_variant : state ctx -> state -> (unit, error) result - - val deserialize_newtype_variant : - state ctx -> state -> ('value, state) t -> ('value, error) result - - val deserialize_tuple_variant : - state ctx -> - state -> - size:int -> - (size:int -> ('value, state) t) -> - ('value, error) result - - val deserialize_record_variant : - state ctx -> - state -> - size:int -> - (size:int -> ('value, state) t) -> - ('value, error) result - - val deserialize_record : - state ctx -> - state -> - name:string -> - size:int -> - ('value, state) t -> - ('value, error) result - - val deserialize_field : - state ctx -> - state -> - name:string -> - ('value, state) t -> - ('value, error) result - - val deserialize_key : - state ctx -> - state -> - ('value, state, 'tag) visitor -> - ('value option, error) result - - val deserialize_identifier : - state ctx -> - state -> - ('value, state, 'tag) visitor -> - ('value, error) result - - val deserialize_string : state ctx -> state -> (string, error) result - val deserialize_int8 : state ctx -> state -> (char, error) result - val deserialize_int16 : state ctx -> state -> (int, error) result - val deserialize_int31 : state ctx -> state -> (int, error) result - val deserialize_int32 : state ctx -> state -> (int32, error) result - val deserialize_int64 : state ctx -> state -> (int64, error) result - val deserialize_bool : state ctx -> state -> (bool, error) result - val deserialize_float : state ctx -> state -> (float, error) result - - val deserialize_option : - state ctx -> state -> ('value, state) t -> ('value option, error) result - end - - type 'state deserializer = (module Deserializer with type state = 'state) -end - -module Visitor = struct - type ('value, 'state, 'tag) t = ('value, 'state, 'tag) De_base.visitor = { - visit_int : 'state De_base.ctx -> int -> ('value, error) result; - visit_string : 'state De_base.ctx -> string -> ('value, error) result; - visit_variant : 'state De_base.ctx -> ('value, error) result; - } - - let default = - De_base. - { - visit_int = (fun _ctx _int -> Error `unimplemented); - visit_string = (fun _ctx _str -> Error `unimplemented); - visit_variant = (fun _ctx -> Error `unimplemented); - } - - let make ?(visit_int = default.visit_int) - ?(visit_string = default.visit_string) () = - { default with visit_int; visit_string } - - let visit_variant ctx t = t.visit_variant ctx - let visit_string ctx t str = t.visit_string ctx str - let visit_int ctx t str = t.visit_int ctx str -end - -module De = struct - include De_base - - let deserialize ctx de = de ctx - - let deserialize_int8 (type state) (((module D), state) as ctx : state ctx) = - D.deserialize_int8 ctx state - - let deserialize_int16 (type state) (((module D), state) as ctx : state ctx) = - D.deserialize_int16 ctx state - - let deserialize_int31 (type state) (((module D), state) as ctx : state ctx) = - D.deserialize_int31 ctx state - - let deserialize_int32 (type state) (((module D), state) as ctx : state ctx) = - D.deserialize_int32 ctx state - - let deserialize_int64 (type state) (((module D), state) as ctx : state ctx) = - D.deserialize_int64 ctx state - - let deserialize_bool (type state) (((module D), state) as ctx : state ctx) = - D.deserialize_bool ctx state - - let deserialize_float (type state) (((module D), state) as ctx : state ctx) = - D.deserialize_float ctx state - - let deserialize_record (type state) (((module D), state) as ctx : state ctx) - name size de = - D.deserialize_record ctx state ~name ~size de - - let deserialize_field (type state) (((module D), state) as ctx : state ctx) - name de = - D.deserialize_field ctx state ~name de - - let deserialize_sequence (type state) (((module D), state) as ctx : state ctx) - size de = - D.deserialize_sequence ctx state ~size de - - let deserialize_element (type state) (((module D), state) as ctx : state ctx) - de = - D.deserialize_element ctx state de - - let deserialize_variant (type state) (((module D), state) as ctx : state ctx) - ~visitor ~name ~variants = - D.deserialize_variant ctx state visitor ~name ~variants - - let deserialize_unit_variant (type state) - (((module D), state) as ctx : state ctx) = - D.deserialize_unit_variant ctx state - - let deserialize_newtype_variant (type state) - (((module D), state) as ctx : state ctx) de = - D.deserialize_newtype_variant ctx state de - - let deserialize_tuple_variant (type state) - (((module D), state) as ctx : state ctx) size de = - D.deserialize_tuple_variant ctx state ~size de - - let deserialize_record_variant (type state) - (((module D), state) as ctx : state ctx) size de = - D.deserialize_record_variant ctx state ~size de - - let deserialize_key (type state) (((module D), state) as ctx : state ctx) - visitor = - D.deserialize_key ctx state visitor - - let deserialize_identifier (type state) - (((module D), state) as ctx : state ctx) visitor = - D.deserialize_identifier ctx state visitor - - let deserialize_string (type state) (((module D), state) as ctx : state ctx) = - D.deserialize_string ctx state - - let deserialize_option (type state) (((module D), state) as ctx : state ctx) - de = - D.deserialize_option ctx state de - - let record ctx name size de = deserialize_record ctx name size de - - let variant ctx name variants visit_variant = - let visitor = { Visitor.default with visit_variant } in - deserialize_variant ctx ~visitor ~name ~variants - - let sequence ctx de = deserialize_sequence ctx 0 de - let bool ctx = deserialize_bool ctx - let int ctx = deserialize_int31 ctx - let int8 ctx = deserialize_int8 ctx - let int16 ctx = deserialize_int16 ctx - let int32 ctx = deserialize_int32 ctx - let int64 ctx = deserialize_int64 ctx - let string ctx = deserialize_string ctx - let identifier ctx visitor = deserialize_identifier ctx visitor - let unit_variant ctx = deserialize_unit_variant ctx - let newtype_variant ctx de = deserialize_newtype_variant ctx de - let tuple_variant ctx size de = deserialize_tuple_variant ctx size de - let record_variant ctx size de = deserialize_record_variant ctx size de - let element ctx de = deserialize_element ctx de - let field ctx name de = deserialize_field ctx name de - let next_field ctx visitor = deserialize_key ctx visitor - let option de ctx = deserialize_option ctx de - let float ctx = deserialize_float ctx - - let list de ctx = - sequence ctx @@ fun ~size:_ ctx -> - let rec read_elements acc = - let* v = element ctx de in - match v with Some s -> read_elements (s :: acc) | None -> Ok acc - in - let* list = read_elements [] in - Ok (List.rev list) - - let array de ctx = - let* list = list de ctx in - Ok (Array.of_list list) - - let d (type state) de ((((module D) as self), state) : state ctx) = - let state = D.nest state in - de (self, state) -end - -module Serializer = struct - type ('state, 'output) t = ('state, 'output) Ser.serializer - - module type Intf = Ser.Serializer - - module Default = struct end -end - -module Deserializer = struct - type 'state t = 'state De.deserializer - - module type Intf = De.Deserializer - - module Default = struct end -end - -let serialize : - type value state output. - (state, output) Serializer.t -> - state -> - (value, state, output) Ser.t -> - value -> - (output, error) result = - fun fmt ctx ser value -> ser value (Ctx (ser, fmt, ctx)) - -let deserialize : - type value state output. - state Deserializer.t -> - state -> - (value, state) De.t -> - (value, error) result = - fun fmt ctx de -> de (fmt, ctx) diff --git a/serde/serde_test.ml b/serde/serde_test.ml deleted file mode 100644 index 582f864..0000000 --- a/serde/serde_test.ml +++ /dev/null @@ -1,611 +0,0 @@ -open Serde - -module Serde_bin = struct - module Serializer = struct - type output = unit - type state = S : { fmt : 'w Rio.Writer.t } -> state - - let nest (S { fmt }) = S { fmt } - - let serialize_none _self (S { fmt; _ }) = - let bytes = Bytes.create 1 in - Bytes.set_int8 bytes 0 0; - Rio.write_all fmt ~buf:(Bytes.to_string bytes) - - let serialize_some self (S { fmt; _ }) de = - let bytes = Bytes.create 1 in - Bytes.set_int8 bytes 0 1; - let* () = Rio.write_all fmt ~buf:(Bytes.to_string bytes) in - Ser.serialize self de - - let serialize_string self (S { fmt; _ }) str = - let* () = Ser.serialize_int31 (String.length str) self in - Rio.write_all fmt ~buf:str - - let serialize_bool self (S _) bool = - let int = if bool then Char.chr 0 else Char.chr 1 in - Ser.serialize_int8 int self - - let serialize_int8 _self (S { fmt; _ }) int = - let bytes = Bytes.create 1 in - Bytes.set bytes 0 int; - Rio.write_all fmt ~buf:(Bytes.to_string bytes) - - let serialize_int16 _self (S { fmt; _ }) int = - let bytes = Bytes.create 2 in - Bytes.set_int16_be bytes 0 int; - Rio.write_all fmt ~buf:(Bytes.to_string bytes) - - let serialize_int31 _self (S { fmt; _ }) int = - let bytes = Bytes.create 4 in - Bytes.set_int32_be bytes 0 (Int32.of_int int); - Rio.write_all fmt ~buf:(Bytes.to_string bytes) - - let serialize_int32 _self (S { fmt; _ }) int = - let bytes = Bytes.create 4 in - Bytes.set_int32_be bytes 0 int; - Rio.write_all fmt ~buf:(Bytes.to_string bytes) - - let serialize_int64 _self (S { fmt; _ }) int = - let bytes = Bytes.create 8 in - Bytes.set_int64_be bytes 0 int; - Rio.write_all fmt ~buf:(Bytes.to_string bytes) - - let serialize_float _self (S { fmt; _ }) float = - let bytes = Bytes.create 8 in - let bof = Int64.bits_of_float float in - Bytes.set_int64_be bytes 0 bof; - Rio.write_all fmt ~buf:(Bytes.to_string bytes) - - let serialize_sequence self (S _) ~size elements = - let* () = Ser.serialize_int31 size self in - Ser.serialize self elements - - let serialize_element self (S _) element = Ser.serialize self element - - let serialize_unit_variant self (S _) ~var_type:_ ~cstr_idx ~cstr_name:_ = - Ser.serialize_int31 cstr_idx self - - let serialize_tuple_variant self (S _) ~var_type:_ ~cstr_idx ~cstr_name:_ - ~size args = - let* () = Ser.serialize_int31 cstr_idx self in - let* () = Ser.serialize_int31 size self in - Ser.serialize self args - - let serialize_newtype_variant self (S _) ~var_type:_ ~cstr_idx ~cstr_name:_ - args = - let* () = Ser.serialize_int31 cstr_idx self in - Ser.serialize self args - - let serialize_record_variant self (S _) ~var_type:_ ~cstr_idx ~cstr_name:_ - ~size args = - let* () = Ser.serialize_int31 cstr_idx self in - let* () = Ser.serialize_int31 size self in - Ser.serialize self args - - let serialize_record self (S _) ~rec_type:_ ~size:_ fields = - Ser.serialize self fields - - let serialize_field self (S _) ~name:_ element = Ser.serialize self element - end - - module Deserializer = struct - type state = - | D : { - reader : 'a Rio.Reader.t; - mutable size : int; - mutable off : int; - } - -> state - - let nest (D { reader; _ }) = D { reader; size = 0; off = 0 } - - let read capacity (D { reader; _ }) = - let bytes = Bytes.create capacity in - let* len = Rio.read reader bytes in - Ok (Bytes.sub bytes 0 len) - - let read_int capacity state fn = - let* bytes = read capacity state in - Ok (fn bytes 0) - - let deserialize_int8 _self state = read_int 1 state Bytes.get - let deserialize_int16 _self state = read_int 2 state Bytes.get_int16_be - - let deserialize_int31 _self state = - let* int = read_int 4 state Bytes.get_int32_be in - Ok (Int32.to_int int) - - let deserialize_int32 _self state = read_int 4 state Bytes.get_int32_be - let deserialize_int64 _self state = read_int 8 state Bytes.get_int64_be - - let deserialize_float _self state = - let* float = read_int 8 state Bytes.get_int64_be in - Ok (Int64.float_of_bits float) - - (* let deserialize_none self _state = *) - (* let* int = De.deserialize_int8 self in *) - (* if Char.equal int (Char.chr 0) then Ok () *) - (* else Error (`Msg "expected 0 to deserialize none") *) - - (* let deserialize_some self _state de = De.deserialize self de *) - - let deserialize_string self state = - let* len = De.deserialize_int31 self in - let* bytes = read len state in - Ok (Bytes.unsafe_to_string bytes) - - let deserialize_bool self _state = - let* bool = De.deserialize_int8 self in - if Char.equal bool (Char.chr 0) then Ok true else Ok false - - let deserialize_sequence self (D s) ~size:_ elements = - let* size = De.deserialize_int31 self in - s.size <- size; - De.deserialize self (elements ~size) - - let deserialize_element self (D s) element = - if s.off < s.size then ( - let* v = De.deserialize self element in - s.off <- s.off + 1; - Ok (Some v)) - else Ok None - - let deserialize_unit_variant _self _state = Ok () - let deserialize_newtype_variant self _state args = De.deserialize self args - - let deserialize_tuple_variant self (D s) ~size:_ args = - let* size = De.deserialize_int31 self in - s.size <- size; - De.deserialize self (args ~size) - - let deserialize_record_variant self (D s) ~size:_ args = - let* size = De.deserialize_int31 self in - s.size <- size; - De.deserialize self (args ~size) - - let deserialize_record self _state ~name:_ ~size:_ fields = - De.deserialize self fields - - let deserialize_field self _state ~name:_ element = - De.deserialize self element - - let deserialize_key _self _state _visitor = Ok None - - let deserialize_identifier self _state visitor = - let* str = De.deserialize_int31 self in - Visitor.visit_int self visitor str - - let deserialize_option self _state de = - let* tag = De.deserialize_int8 self in - if Char.equal tag (Char.chr 0) then Ok None - else - let* v = De.deserialize self de in - Ok (Some v) - - let deserialize_variant self _state visitor ~name:_ ~variants:_ = - Visitor.visit_variant self visitor - end - - let to_string ser value = - let buf = Buffer.create 0 in - let state = Serializer.S { fmt = Rio.Buffer.to_writer buf } in - let* () = Serde.serialize (module Serializer) state ser value in - Ok (Buffer.to_bytes buf |> Bytes.unsafe_to_string) - - let of_string de string = - let module StrRead = struct - type t = { src : string; mutable pos : int } - - let make src = { src; pos = 0 } - - let read t ?timeout:_ dst = - let src = t.src in - let len = Int.min (String.length src - t.pos) (Bytes.length dst) in - BytesLabels.blit_string ~src ~src_pos:t.pos ~dst ~dst_pos:0 ~len; - t.pos <- t.pos + len; - Ok len - - let read_vectored _src _iov = Ok 0 - end in - let reader = - Rio.Reader.of_read_src (module StrRead) StrRead.(make string) - in - let state = Deserializer.(D { reader; size = 0; off = 0 }) in - Serde.deserialize (module Deserializer) state de -end - -let keyword fmt = Spices.(default |> fg (color "#00FF00") |> build) fmt -let error fmt = Spices.(default |> fg (color "#FF0000") |> build) fmt - -type simple_variant = A -type variant_with_arg = B of int -type variant_with_many_args = C of int * string * float -type simple_record = { name : string; year : int [@warning "-69"] } -type variant_with_inline_record = D of { is_inline : bool } -type nested = { nested_flag : bool } -type record_nested = { nested : nested } -type record_with_list = { keys : string list; collection : string } -type with_option = string option -type with_nested_option = { nested_opt : with_option } -type with_list = string list -type with_array = string array - -let pp_variant fmt A = Format.fprintf fmt "A" -let pp_variant_with_arg fmt (B i) = Format.fprintf fmt "(B %d)" i - -let pp_variant_with_many_arg fmt (C (i, str, float)) = - Format.fprintf fmt "(C (%d, %S, %F))" i str float - -let pp_record fmt { name; year } = - Format.fprintf fmt "{name=%S;year=%d}" name year - -let pp_variant_with_inline_record fmt (D { is_inline }) = - Format.fprintf fmt "(D {is_inline=%b})" is_inline - -let pp_record_nested fmt { nested = { nested_flag } } = - Format.fprintf fmt "({nested={nested_flag=%b}})" nested_flag - -let pp_with_option fmt opt = - match opt with - | None -> Format.fprintf fmt "None" - | Some s -> Format.fprintf fmt "(Some %S)" s - -let pp_with_nested_option fmt { nested_opt } = - Format.fprintf fmt "({nested_opt=%a})" pp_with_option nested_opt - -let pp_with_list fmt (t : with_list) = - Format.fprintf fmt "["; - Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt "; ") - (fun fmt s -> Format.fprintf fmt "%S" s) - fmt t; - Format.fprintf fmt "]" - -let pp_with_array fmt (t : with_array) = - Format.fprintf fmt "[|"; - Format.pp_print_array - ~pp_sep:(fun fmt () -> Format.fprintf fmt "; ") - (fun fmt s -> Format.fprintf fmt "%S" s) - fmt t; - Format.fprintf fmt "|]" - -let pp_record_with_list fmt { keys; collection } = - Format.fprintf fmt "{keys=%a;collection=%S}" pp_with_list keys collection - -let _serde_bin_roundtrip_tests = - let test str pp ser de value expect_str = - let actual_str = - match - let* bin = Serde_bin.to_string ser value in - (* Format.printf "bin: %S for %a\n%!" bin pp value; *) - Serde_bin.of_string de bin - with - | Ok actual -> Format.asprintf "%a" pp actual - | Error err -> Format.asprintf "Exception: %a" Serde.pp_err err - in - - if String.equal actual_str expect_str then - Format.printf "serde_bin.ser/de test %S %s\r\n%!" str (keyword "OK") - else ( - Format.printf "%s\n\nExpected:\n\n%s\n\nbut found:\n\n%s\n\n" - (error "bin does not match") - expect_str actual_str; - assert false) - in - - test "variant_without_args" pp_variant - Ser.(serializer @@ fun A ctx -> unit_variant ctx "simple_variant" 0 "A") - De.( - deserializer @@ fun ctx -> - let field_visitor = - Visitor. - { - default with - visit_int = - (fun _ctx int -> if int = 0 then Ok `A else Error `invalid_tag); - } - in - - variant ctx "simple_variant" [ "A" ] @@ fun ctx -> - let* `A = identifier ctx field_visitor in - let* () = unit_variant ctx in - Ok A) - A "A"; - - test "variant_without_args and wrong serialization" pp_variant - Ser.( - serializer @@ fun A ctx -> - unit_variant ctx "simple_variant" 199 "Wrong_variant_name") - De.( - deserializer @@ fun ctx -> - let field_visitor = - Visitor. - { - default with - visit_int = - (fun _ctx int -> if int = 0 then Ok `A else Error `invalid_tag); - } - in - - variant ctx "simple_variant" [ "A" ] @@ fun ctx -> - let* `A = identifier ctx field_visitor in - let* () = unit_variant ctx in - Ok A) - A "Exception: invalid_tag"; - - test "variant with one arg" pp_variant_with_arg - Ser.( - serializer @@ fun (B i) ctx -> - newtype_variant ctx "simple_variant" 0 "B" (int i)) - De.( - deserializer @@ fun ctx -> - let field_visitor = - Visitor. - { - default with - visit_int = - (fun _ctx int -> if int = 0 then Ok `B else Error `invalid_tag); - } - in - - variant ctx "simple_variant" [ "B" ] @@ fun ctx -> - let* `B = identifier ctx field_visitor in - newtype_variant ctx @@ fun ctx -> - let* i = int ctx in - Ok (B i)) - (B 2112) "(B 2112)"; - - test "variant with one arg and wrong serialization" pp_variant_with_arg - Ser.( - serializer @@ fun (B i) ctx -> - newtype_variant ctx "simple_variant" 990 "Wrong_variant" (int i)) - De.( - deserializer @@ fun ctx -> - let field_visitor = - Visitor. - { - default with - visit_int = - (fun _ctx int -> if int = 0 then Ok `B else Error `invalid_tag); - } - in - - variant ctx "simple_variant" [ "B" ] @@ fun ctx -> - let* `B = identifier ctx field_visitor in - newtype_variant ctx @@ fun ctx -> - let* i = int ctx in - Ok (B i)) - (B 2112) "Exception: invalid_tag"; - - test "variant with many args" pp_variant_with_many_arg - Ser.( - serializer @@ fun (C (i, str, flt)) ctx -> - tuple_variant ctx "variant_with_many_args" 0 "C" 3 @@ fun ctx -> - let* () = element ctx (int i) in - let* () = element ctx (string str) in - let* () = element ctx (float flt) in - Ok ()) - De.( - deserializer @@ fun ctx -> - let field_visitor = - Visitor. - { - default with - visit_int = - (fun _ctx int -> if int = 0 then Ok `C else Error `invalid_tag); - } - in - - variant ctx "variant_with_many_args" [ "C" ] @@ fun ctx -> - let* `C = identifier ctx field_visitor in - tuple_variant ctx 3 @@ fun ~size:_ ctx -> - let* i = element ctx int in - let i = Option.get i in - let* str = element ctx string in - let str = Option.get str in - let* flt = element ctx float in - let flt = Option.get flt in - Ok (C (i, str, flt))) - (C (2112, "rush", Float.pi)) - {|(C (2112, "rush", 3.14159265359))|}; - - test "record_with_one_arg" pp_record - Ser.( - serializer @@ fun r ctx -> - record ctx "simple_record" 2 @@ fun ctx -> - let* () = field ctx "name" (string r.name) in - let* () = field ctx "year" (int r.year) in - Ok ()) - De.( - deserializer @@ fun ctx -> - record ctx "record" 2 @@ fun ctx -> - let* name = field ctx "name" string in - let* year = field ctx "year" int in - Ok { name; year }) - { name = "rush"; year = 2112 } - {|{name="rush";year=2112}|}; - - test "variant with inline record" pp_variant_with_inline_record - Ser.( - serializer @@ fun (D { is_inline }) ctx -> - record_variant ctx "variant_with_many_args" 0 "C" 2 @@ fun ctx -> - let* () = field ctx "is_inline" (bool is_inline) in - Ok ()) - De.( - deserializer @@ fun ctx -> - let field_visitor = - Visitor. - { - default with - visit_int = - (fun _ctx int -> if int = 0 then Ok `D else Error `invalid_tag); - } - in - - variant ctx "variant_with_many_args" [ "C" ] @@ fun ctx -> - let* `D = identifier ctx field_visitor in - record_variant ctx 2 @@ fun ~size:_ ctx -> - let* is_inline = field ctx "is_inline" bool in - Ok (D { is_inline })) - (D { is_inline = true }) - {|(D {is_inline=true})|}; - - test "record_with_nested_records" pp_record_nested - Ser.( - let nested_serializer = - serializer @@ fun nr ctx -> - record ctx "nested" 1 @@ fun ctx -> - field ctx "nested_flag" (bool nr.nested_flag) - in - serializer @@ fun r ctx -> - record ctx "record_nested" 1 @@ fun ctx -> - field ctx "nested" (s nested_serializer r.nested)) - De.( - let nested_deserializer = - deserializer @@ fun ctx -> - record ctx "record_nested" 1 @@ fun ctx -> - let* nested_flag = field ctx "nested_flag" bool in - Ok { nested_flag } - in - deserializer @@ fun ctx -> - record ctx "nested" 1 @@ fun _ctx -> - let* nested = field ctx "nested" (d nested_deserializer) in - Ok { nested }) - { nested = { nested_flag = false } } - {|({nested={nested_flag=false}})|}; - - let option_serializer = - Ser.(serializer @@ fun opt ctx -> option string opt ctx) - in - let option_deserializer = De.(deserializer @@ fun ctx -> option string ctx) in - test "option/some" pp_with_option option_serializer option_deserializer - (Some "rush" : with_option) - {|(Some "rush")|}; - - test "option/none" pp_with_option option_serializer option_deserializer None - {|None|}; - - let list_serializer = - Ser.( - serializer @@ fun ls ctx -> - sequence ctx (List.length ls) @@ fun ctx -> - List.fold_left - (fun acc el -> - match acc with Ok () -> element ctx (string el) | _ -> acc) - (Ok ()) ls) - in - - let list_deserializer = - De.( - deserializer @@ fun ctx -> - sequence ctx @@ fun ~size ctx -> - let rec read_elements size acc = - if size = 0 then Ok (List.rev acc) - else - let* v = element ctx string in - match v with - | Some s -> read_elements (size - 1) (s :: acc) - | None -> Ok (List.rev acc) - in - read_elements size []) - in - test "list/empty" pp_with_list list_serializer list_deserializer - ([] : with_list) - {|[]|}; - - test "list/singleton" pp_with_list list_serializer list_deserializer - ([ "rush" ] : with_list) - {|["rush"]|}; - - test "list/many" pp_with_list list_serializer list_deserializer - ([ "rush"; "tom sawyer"; "xanadu"; "2112" ] : with_list) - {|["rush"; "tom sawyer"; "xanadu"; "2112"]|}; - - let array_serializer = - Ser.( - serializer @@ fun ls ctx -> - sequence ctx (Array.length ls) @@ fun ctx -> - Array.fold_left - (fun acc el -> - match acc with Ok () -> element ctx (string el) | _ -> acc) - (Ok ()) ls) - in - - let array_deserializer = - De.( - deserializer @@ fun ctx -> - sequence ctx @@ fun ~size ctx -> - let rec read_elements size acc = - if size = 0 then Ok (List.rev acc) - else - let* v = element ctx string in - match v with - | Some s -> read_elements (size - 1) (s :: acc) - | None -> Ok (List.rev acc) - in - let* list = read_elements size [] in - Ok (Array.of_list list)) - in - test "array/empty" pp_with_array array_serializer array_deserializer - ([||] : with_array) - {|[||]|}; - - test "array/singleton" pp_with_array array_serializer array_deserializer - ([| "rush" |] : with_array) - {|[|"rush"|]|}; - - test "array/many" pp_with_array array_serializer array_deserializer - ([| "rush"; "tom sawyer"; "xanadu"; "2112" |] : with_array) - {|[|"rush"; "tom sawyer"; "xanadu"; "2112"|]|}; - - let nested_opt_ser = - Ser.( - serializer @@ fun r ctx -> - record ctx "with_nested_option" 1 @@ fun ctx -> - field ctx "nested_opt" (s option_serializer r.nested_opt)) - in - let nested_opt_de = - De.( - deserializer @@ fun ctx -> - record ctx "with_nested_option" 1 @@ fun ctx -> - let* nested_opt = field ctx "nested_opt" option_deserializer in - Ok { nested_opt }) - in - test "record with nested option/none" pp_with_nested_option nested_opt_ser - nested_opt_de { nested_opt = None } {|({nested_opt=None})|}; - test "record with nested option/some" pp_with_nested_option nested_opt_ser - nested_opt_de - { nested_opt = Some "rush" } - {|({nested_opt=(Some "rush")})|}; - - test "record_with_list" pp_record_with_list - Ser.( - serializer @@ fun r ctx -> - record ctx "record_with_list" 1 @@ fun ctx -> - let* () = field ctx "keys" (list string r.keys) in - field ctx "collection" (string r.collection)) - De.( - deserializer @@ fun ctx -> - record ctx "record_with_list" 1 @@ fun ctx -> - let* keys = field ctx "keys" (list string) in - let* collection = field ctx "collection" string in - Ok { keys; collection }) - { keys = [ "rush"; "genesis"; "foo fighters" ]; collection = "bands" } - {|{keys=["rush"; "genesis"; "foo fighters"];collection="bands"}|}; - - test "record_with_list/empty" pp_record_with_list - Ser.( - serializer @@ fun r ctx -> - record ctx "record_with_list" 1 @@ fun ctx -> - let* () = field ctx "keys" (s (list string) r.keys) in - field ctx "collection" (string r.collection)) - De.( - deserializer @@ fun ctx -> - record ctx "record_with_list" 1 @@ fun ctx -> - let* keys = field ctx "keys" (d (list string)) in - let* collection = field ctx "collection" string in - Ok { keys; collection }) - { keys = []; collection = "bands" } - {|{keys=[];collection="bands"}|}; - () diff --git a/serde_derive.opam b/serde_derive.opam deleted file mode 100644 index 1f73c4b..0000000 --- a/serde_derive.opam +++ /dev/null @@ -1,33 +0,0 @@ -# This file is generated by dune, edit dune-project instead -opam-version: "2.0" -synopsis: "Derive-macros for the Serde serialization framework" -description: - "These macros help derive serializers and deserializers for your existing types and provide all the functionality you expect to plug in different data-formats." -maintainer: ["Leandro Ostera "] -authors: ["Leandro Ostera "] -license: "MIT" -homepage: "https://github.com/serde-ml/serde" -bug-reports: "https://github.com/serde-ml/serde/issues" -depends: [ - "ocaml" {>= "5.1.1"} - "ppx_deriving" {>= "5.2.1"} - "ppxlib" {>= "0.28.0"} - "serde" {= version} - "dune" {>= "3.13"} - "odoc" {with-doc} -] -build: [ - ["dune" "subst"] {dev} - [ - "dune" - "build" - "-p" - name - "-j" - jobs - "@install" - "@runtest" {with-test} - "@doc" {with-doc} - ] -] -dev-repo: "git+https://github.com/serde-ml/serde.git" diff --git a/serde_json.opam b/serde_json.opam index 0f80d13..836d2ca 100644 --- a/serde_json.opam +++ b/serde_json.opam @@ -4,8 +4,8 @@ synopsis: "JSON format support for Serde" maintainer: ["Leandro Ostera "] authors: ["Leandro Ostera "] license: "MIT" -homepage: "https://github.com/serde-ml/serde" -bug-reports: "https://github.com/serde-ml/serde/issues" +homepage: "https://github.com/serde-ml/json" +bug-reports: "https://github.com/serde-ml/json/issues" depends: [ "ocaml" {>= "5.1.1"} "ppx_inline_test" {>= "v0.16.0"} @@ -32,4 +32,4 @@ build: [ "@doc" {with-doc} ] ] -dev-repo: "git+https://github.com/serde-ml/serde.git" +dev-repo: "git+https://github.com/serde-ml/json.git" diff --git a/serde_json/serde_json_test.ml b/serde_json/serde_json_test.ml index 9a3bd55..2f196db 100644 --- a/serde_json/serde_json_test.ml +++ b/serde_json/serde_json_test.ml @@ -175,7 +175,7 @@ let _serde_json_roundtrip_tests = tuple_variant ctx "variant_with_many_args" 0 "C" 3 @@ fun ctx -> let* () = element ctx (int32 i) in let* () = element ctx (string str) in - let* () = element ctx (float flt) in + let* () = element ctx (Ser.float flt) in Ok ()) De.( deserializer @@ fun ctx ->