From 7a61ac25f1c9f9c96825d7a02659440aaa500b99 Mon Sep 17 00:00:00 2001 From: Ben Bellick Date: Mon, 9 Dec 2024 22:51:47 -0500 Subject: [PATCH 1/6] wip: deriving for type vars --- src/decoders_deriver.ml | 21 +++++++++++++++++++++ test/test_decoders.ml | 2 ++ 2 files changed, 23 insertions(+) diff --git a/src/decoders_deriver.ml b/src/decoders_deriver.ml index 936b0cb..9087647 100644 --- a/src/decoders_deriver.ml +++ b/src/decoders_deriver.ml @@ -114,6 +114,8 @@ let rec expr_of_typ (typ : core_type) match CCList.assoc_opt ~eq other_type substitutions with | Some replacement -> replacement | None -> Ast_builder.Default.evar ~loc (to_decoder_name lid)) + | { ptyp_desc = Ptyp_var var; _ } -> + Ast_builder.Default.evar ~loc @@ to_decoder_name var | _ -> Location.raise_errorf ~loc "Cannot construct decoder for %s" (string_of_core_type typ) @@ -302,6 +304,7 @@ let single_type_decoder_gen ~(loc : location) ~rec_flag type_decl : structure_item list = let rec_flag = really_recursive rec_flag [ type_decl ] in let name = to_decoder_name type_decl.ptype_name.txt in + let substitutions = match rec_flag with | Nonrecursive -> [] @@ -315,6 +318,24 @@ let single_type_decoder_gen ~(loc : location) ~rec_flag type_decl : implementation_generator ~loc ~rec_flag ~substitutions type_decl in let name = to_decoder_name type_decl.ptype_name.txt in + let params = + (* TODO: can we drop the non type vars? What are these? *) + CCList.filter_map + (fun (param, _) -> + match param.ptyp_desc with Ptyp_var var -> Some var | _ -> None) + type_decl.ptype_params + in + let args = + CCList.map + (fun param -> Ast_builder.Default.pvar ~loc (to_decoder_name param)) + params + in + let imple = + (* We need the type variables to become arguments *) + CCList.fold_left + (fun impl arg -> [%expr fun [%p arg] -> [%e impl]]) + imple args + in [%str let [%p Ast_builder.Default.pvar ~loc name] = [%e imple]] let rec mutual_rec_fun_gen ~loc diff --git a/test/test_decoders.ml b/test/test_decoders.ml index 184dcef..84abdf7 100644 --- a/test/test_decoders.ml +++ b/test/test_decoders.ml @@ -49,6 +49,8 @@ type a1 = { l : b1 option; m : c1 option } and b1 = { n : c1 } and c1 = { o : a1 } [@@deriving decoders] +type 'a with_type_var = { wrapped : 'a } [@@deriving decoders] + let%test "int" = match D.decode_string my_int_decoder "1234" with | Ok i -> i = 1234 From 77f037ca148ce93d8718ff96a0e1d4e167bc74a2 Mon Sep 17 00:00:00 2001 From: Ben Bellick Date: Thu, 12 Dec 2024 22:38:12 -0600 Subject: [PATCH 2/6] correct handling of simple type variable --- src/decoders_deriver.ml | 24 +++++++----------------- test/test_decoders.ml | 8 +++++++- 2 files changed, 14 insertions(+), 18 deletions(-) diff --git a/src/decoders_deriver.ml b/src/decoders_deriver.ml index 9087647..90fa516 100644 --- a/src/decoders_deriver.ml +++ b/src/decoders_deriver.ml @@ -15,23 +15,6 @@ let apply_substitution ~orig ~substi = in mapper#expression -(* let suppress_warning_27 = *) -(* let suppress_warning_27 = *) -(* let loc = Location.none in *) -(* let payload = *) -(* PStr *) -(* [ *) -(* Ast_helper.Str.eval *) -(* (Ast_helper.Exp.constant (Pconst_string ("-27", loc, None))); *) -(* ] *) -(* in *) -(* let attr_name = "ocaml.warning" *) - -(* in *) -(* let attribute = Ast_builder.Default.attribute ~loc ~name:attr_name ~payload in *) -(* Ast_builder.Default.pstr_attribute ~loc attribute *) - -(* let enforce_warning_27 = _ *) let to_decoder_name i = i ^ "_decoder" let decoder_pvar_of_type_decl type_decl = @@ -116,6 +99,13 @@ let rec expr_of_typ (typ : core_type) | None -> Ast_builder.Default.evar ~loc (to_decoder_name lid)) | { ptyp_desc = Ptyp_var var; _ } -> Ast_builder.Default.evar ~loc @@ to_decoder_name var + | { ptyp_desc = Ptyp_constr ({ txt = Lident name; _ }, args); _ } -> + let cstr_dec = Ast_builder.Default.evar ~loc @@ to_decoder_name name in + + let arg_decs = CCList.map (expr_of_typ ~substitutions) args in + Ast_builder.Default.eapply ~loc cstr_dec arg_decs + (* Location.raise_errorf ~loc "Cannot constructor decoder for %s" *) + (* (string_of_core_type typ) *) | _ -> Location.raise_errorf ~loc "Cannot construct decoder for %s" (string_of_core_type typ) diff --git a/test/test_decoders.ml b/test/test_decoders.ml index 84abdf7..6bfc80f 100644 --- a/test/test_decoders.ml +++ b/test/test_decoders.ml @@ -49,7 +49,8 @@ type a1 = { l : b1 option; m : c1 option } and b1 = { n : c1 } and c1 = { o : a1 } [@@deriving decoders] -type 'a with_type_var = { wrapped : 'a } [@@deriving decoders] +type 'a record_wrapper = { wrapped : 'a } [@@deriving decoders] +type int_record_wrapper = int record_wrapper [@@deriving decoders] let%test "int" = match D.decode_string my_int_decoder "1234" with @@ -235,3 +236,8 @@ let%test "expression mutually-recursive decoder" = | Error e -> print_endline @@ D.string_of_error e; false + +let%test "simple type var" = + match D.decode_string int_record_wrapper_decoder {|{"wrapped":-2389}|} with + | Ok { wrapped = -2389 } -> true + | _ -> false From 20f4b48fb59055536a6986a45f483d9e12ff0ae8 Mon Sep 17 00:00:00 2001 From: Ben Bellick Date: Sat, 14 Dec 2024 10:04:26 -0600 Subject: [PATCH 3/6] improved handling of modules --- src/decoders_deriver.ml | 39 +++++++++++++++++++++++++-------------- test/test_decoders.ml | 24 ++++++++++++++++++++++++ 2 files changed, 49 insertions(+), 14 deletions(-) diff --git a/src/decoders_deriver.ml b/src/decoders_deriver.ml index 90fa516..7ec6338 100644 --- a/src/decoders_deriver.ml +++ b/src/decoders_deriver.ml @@ -17,13 +17,21 @@ let apply_substitution ~orig ~substi = let to_decoder_name i = i ^ "_decoder" +let rec flatten_longident = function + | Lident txt -> txt + | Ldot (longident, txt) -> flatten_longident longident ^ "." ^ txt + | Lapply _ -> failwith "oops" + +let longident_to_decoder_name = CCFun.(to_decoder_name % flatten_longident) +let name_to_decoder_name (i : string loc) = to_decoder_name i.txt + let decoder_pvar_of_type_decl type_decl = Ast_builder.Default.pvar ~loc:type_decl.ptype_name.loc - (to_decoder_name type_decl.ptype_name.txt) + (name_to_decoder_name type_decl.ptype_name) let decoder_evar_of_type_decl type_decl = Ast_builder.Default.evar ~loc:type_decl.ptype_name.loc - (to_decoder_name type_decl.ptype_name.txt) + (name_to_decoder_name type_decl.ptype_name) (** We take an expr implementation with name NAME and turn it into: let rec NAME_AUX = fun () -> expr in NAME_AUX (). @@ -87,7 +95,7 @@ let rec expr_of_typ (typ : core_type) (* failwith *) (* (Format.sprintf "This alias was a failure...: %s\n" *) (* (string_of_core_type typ)) *) - | { ptyp_desc = Ptyp_constr ({ txt = Lident lid; _ }, []); _ } as other_type + | { ptyp_desc = Ptyp_constr ({ txt = longident; _ }, []); _ } as other_type -> ( (* In the case where our type is truly recursive, we need to instead do `type_aux ()` *) let eq (ct1 : core_type) (ct2 : core_type) = @@ -96,11 +104,14 @@ let rec expr_of_typ (typ : core_type) in match CCList.assoc_opt ~eq other_type substitutions with | Some replacement -> replacement - | None -> Ast_builder.Default.evar ~loc (to_decoder_name lid)) + | None -> + Ast_builder.Default.evar ~loc (longident_to_decoder_name longident)) | { ptyp_desc = Ptyp_var var; _ } -> Ast_builder.Default.evar ~loc @@ to_decoder_name var - | { ptyp_desc = Ptyp_constr ({ txt = Lident name; _ }, args); _ } -> - let cstr_dec = Ast_builder.Default.evar ~loc @@ to_decoder_name name in + | { ptyp_desc = Ptyp_constr ({ txt = longident; _ }, args); _ } -> + let cstr_dec = + Ast_builder.Default.evar ~loc @@ longident_to_decoder_name longident + in let arg_decs = CCList.map (expr_of_typ ~substitutions) args in Ast_builder.Default.eapply ~loc cstr_dec arg_decs @@ -276,7 +287,7 @@ let expr_of_variant ~loc ~substitutions cstrs = let implementation_generator ~(loc : location) ~rec_flag ~substitutions type_decl : expression = let rec_flag = really_recursive rec_flag [ type_decl ] in - let name = to_decoder_name type_decl.ptype_name.txt in + let name = name_to_decoder_name type_decl.ptype_name in let imple_expr = match (type_decl.ptype_kind, type_decl.ptype_manifest) with | Ptype_abstract, Some manifest -> expr_of_typ ~substitutions manifest @@ -293,7 +304,7 @@ let implementation_generator ~(loc : location) ~rec_flag ~substitutions let single_type_decoder_gen ~(loc : location) ~rec_flag type_decl : structure_item list = let rec_flag = really_recursive rec_flag [ type_decl ] in - let name = to_decoder_name type_decl.ptype_name.txt in + let name = name_to_decoder_name type_decl.ptype_name in let substitutions = match rec_flag with @@ -307,7 +318,7 @@ let single_type_decoder_gen ~(loc : location) ~rec_flag type_decl : let imple = implementation_generator ~loc ~rec_flag ~substitutions type_decl in - let name = to_decoder_name type_decl.ptype_name.txt in + let name = name_to_decoder_name type_decl.ptype_name in let params = (* TODO: can we drop the non type vars? What are these? *) CCList.filter_map @@ -337,12 +348,12 @@ let rec mutual_rec_fun_gen ~loc | type_decl :: rest -> let var = pvar ~loc:type_decl.ptype_name.loc - (to_decoder_name type_decl.ptype_name.txt) + (name_to_decoder_name type_decl.ptype_name) in let substitutions = match really_recursive Recursive [ type_decl ] with | Recursive -> - let name = to_decoder_name type_decl.ptype_name.txt in + let name = name_to_decoder_name type_decl.ptype_name in let substi = Ast_builder.Default.evar ~loc (name ^ "_aux") in let new_substitution = (core_type_of_type_declaration type_decl, substi) @@ -367,7 +378,7 @@ let rec mutual_rec_fun_gen ~loc else List.map (fun type_decl -> - let name = to_decoder_name type_decl.ptype_name.txt in + let name = name_to_decoder_name type_decl.ptype_name in pvar ~loc:type_decl.ptype_name.loc name) rest in @@ -375,10 +386,10 @@ let rec mutual_rec_fun_gen ~loc let dec = [%stri let [%p var] = [%e imple_as_lambda]] in let substi = pexp_apply ~loc - (evar ~loc (to_decoder_name type_decl.ptype_name.txt)) + (evar ~loc (name_to_decoder_name type_decl.ptype_name)) (List.map (fun decl -> - (Nolabel, evar ~loc (to_decoder_name decl.ptype_name.txt))) + (Nolabel, evar ~loc (name_to_decoder_name decl.ptype_name))) rest) in let new_substitution = diff --git a/test/test_decoders.ml b/test/test_decoders.ml index 6bfc80f..b65310b 100644 --- a/test/test_decoders.ml +++ b/test/test_decoders.ml @@ -241,3 +241,27 @@ let%test "simple type var" = match D.decode_string int_record_wrapper_decoder {|{"wrapped":-2389}|} with | Ok { wrapped = -2389 } -> true | _ -> false + +module Blah = struct + type t = int [@@deriving decoders] +end + +type blah_wrapped = Blah.t record_wrapper [@@deriving decoders] + +let%test "basic module-wrapped type" = + match D.decode_string blah_wrapped_decoder {|{"wrapped":10110}|} with + | Ok { wrapped = 10110 } -> true + | _ -> false + +module Outer = struct + module Inner = struct + type t = string [@@deriving decoders] + end +end + +type outer_inner_wrapped = Outer.Inner.t record_wrapper [@@deriving decoders] + +let%test "basic module-wrapped type" = + match D.decode_string outer_inner_wrapped_decoder {|{"wrapped":"value"}|} with + | Ok { wrapped = "value" } -> true + | _ -> false From b72bec45e741421ff3b3b6278240a8cf898f3735 Mon Sep 17 00:00:00 2001 From: Ben Bellick Date: Sat, 14 Dec 2024 10:31:58 -0600 Subject: [PATCH 4/6] better handling of type vars and of modules --- src/decoders_deriver.ml | 6 ++-- src/encoders_deriver.ml | 61 ++++++++++++++++++++++++++++++++++------- test/test_decoders.ml | 10 +++++++ test/test_encoders.ml | 29 ++++++++++++++++++++ 4 files changed, 94 insertions(+), 12 deletions(-) diff --git a/src/decoders_deriver.ml b/src/decoders_deriver.ml index 7ec6338..a9c4dee 100644 --- a/src/decoders_deriver.ml +++ b/src/decoders_deriver.ml @@ -20,7 +20,9 @@ let to_decoder_name i = i ^ "_decoder" let rec flatten_longident = function | Lident txt -> txt | Ldot (longident, txt) -> flatten_longident longident ^ "." ^ txt - | Lapply _ -> failwith "oops" + | Lapply _ -> + (* TODO: when would this happen? *) + failwith "oops" let longident_to_decoder_name = CCFun.(to_decoder_name % flatten_longident) let name_to_decoder_name (i : string loc) = to_decoder_name i.txt @@ -431,7 +433,7 @@ let str_gens ~(loc : location) ~(path : label) let _path = path in match (really_recursive rec_flag type_decls, type_decls) with | Nonrecursive, _ -> - List.(flatten (map (single_type_decoder_gen ~loc ~rec_flag) type_decls)) + CCList.flat_map (single_type_decoder_gen ~loc ~rec_flag) type_decls | Recursive, [ type_decl ] -> Utils.wrap_27 @@ single_type_decoder_gen ~loc ~rec_flag type_decl | Recursive, _type_decls -> diff --git a/src/encoders_deriver.ml b/src/encoders_deriver.ml index 8ba0fd2..72a1779 100644 --- a/src/encoders_deriver.ml +++ b/src/encoders_deriver.ml @@ -2,6 +2,16 @@ open Ppxlib let to_encoder_name i = i ^ "_encoder" +let rec flatten_longident = function + | Lident txt -> txt + | Ldot (longident, txt) -> flatten_longident longident ^ "." ^ txt + | Lapply _ -> + (* TODO: when would this happen? *) + failwith "oops" + +let longident_to_encoder_name = CCFun.(to_encoder_name % flatten_longident) +let name_to_encoder_name (i : string loc) = to_encoder_name i.txt + let rec expr_of_typ (typ : core_type) : expression = let loc = { typ.ptyp_loc with loc_ghost = true } in match typ with @@ -23,26 +33,35 @@ let rec expr_of_typ (typ : core_type) : expression = | [%type: bytes] | [%type: Bytes.t] -> failwith "Cannot handle Bytes" (* TODO: figure out strategy *) | [%type: [%t? inner_typ] list] -> - let list_decoder = Ast_builder.Default.evar ~loc "E.list" in + let list_encoder = Ast_builder.Default.evar ~loc "E.list" in let sub_expr = expr_of_typ inner_typ in - Ast_helper.Exp.apply ~loc list_decoder [ (Nolabel, sub_expr) ] + Ast_helper.Exp.apply ~loc list_encoder [ (Nolabel, sub_expr) ] | [%type: [%t? inner_typ] array] -> - let array_decoder = Ast_builder.Default.evar ~loc "E.array" in + let array_encoder = Ast_builder.Default.evar ~loc "E.array" in let sub_expr = expr_of_typ inner_typ in - Ast_helper.Exp.apply ~loc array_decoder [ (Nolabel, sub_expr) ] + Ast_helper.Exp.apply ~loc array_encoder [ (Nolabel, sub_expr) ] | [%type: [%t? inner_typ] option] -> - let opt_decoder = Ast_builder.Default.evar ~loc "E.nullable" in + let opt_encoder = Ast_builder.Default.evar ~loc "E.nullable" in let sub_expr = expr_of_typ (* ~substitutions *) inner_typ in - Ast_helper.Exp.apply ~loc opt_decoder [ (Nolabel, sub_expr) ] + Ast_helper.Exp.apply ~loc opt_encoder [ (Nolabel, sub_expr) ] | { ptyp_desc = Ptyp_tuple typs; _ } -> expr_of_tuple ~loc typs + | { ptyp_desc = Ptyp_var var; _ } -> + Ast_builder.Default.evar ~loc @@ to_encoder_name var | { ptyp_desc = Ptyp_constr ({ txt = Lident lid; _ }, []); _ } -> (* The assumption here is that if we get to this point, this type is recursive, and we just assume that we already have an encoder available. TODO: Is this really the case? *) Ast_builder.Default.evar ~loc (to_encoder_name lid) + | { ptyp_desc = Ptyp_constr ({ txt = longident; _ }, args); _ } -> + let cstr_dec = + Ast_builder.Default.evar ~loc @@ longident_to_encoder_name longident + in + + let arg_decs = CCList.map expr_of_typ args in + Ast_builder.Default.eapply ~loc cstr_dec arg_decs | _ -> - Location.raise_errorf ~loc "Cannot construct decoder for %s" + Location.raise_errorf ~loc "Cannot construct encoder for %s" (string_of_core_type typ) and expr_of_tuple ~loc (* ~substitutions ?lift *) typs = @@ -184,23 +203,45 @@ let implementation_generator ~(loc : location) type_decl : expression = in imple_expr -let single_type_decoder_gen ~(loc : location) type_decl = +let single_type_encoder_gen ~(loc : location) type_decl = let imple = implementation_generator ~loc type_decl in let name = to_encoder_name type_decl.ptype_name.txt in let pat = Ast_builder.Default.pvar ~loc name in + let params = + (* TODO: can we drop the non type vars? What are these? *) + CCList.filter_map + (fun (param, _) -> + match param.ptyp_desc with Ptyp_var var -> Some var | _ -> None) + type_decl.ptype_params + in + let args = + CCList.map + (fun param -> Ast_builder.Default.pvar ~loc (to_encoder_name param)) + params + in + let imple = + (* We need the type variables to become arguments *) + CCList.fold_left + (fun impl arg -> [%expr fun [%p arg] -> [%e impl]]) + imple args + in Ast_builder.Default.value_binding ~loc ~pat ~expr:imple +(* [%str let [%p Ast_builder.Default.pvar ~loc name] = [%e imple]] *) let str_gens ~(loc : location) ~(path : label) ((rec_flag : rec_flag), type_decls) : structure_item list = let _path = path in + let rec_flag = really_recursive rec_flag type_decls in + + (* CCList.flat_map (single_type_encoder_gen ~loc ~rec_flag) type_decls *) match (really_recursive rec_flag type_decls, type_decls) with | Nonrecursive, _ -> [ (Ast_builder.Default.pstr_value ~loc Nonrecursive - @@ List.(map (single_type_decoder_gen ~loc) type_decls)); + @@ List.(map (single_type_encoder_gen ~loc) type_decls)); ] | Recursive, type_decls -> [ (Ast_builder.Default.pstr_value ~loc Recursive - @@ List.(map (single_type_decoder_gen ~loc) type_decls)); + @@ List.(map (single_type_encoder_gen ~loc) type_decls)); ] diff --git a/test/test_decoders.ml b/test/test_decoders.ml index b65310b..77feb8d 100644 --- a/test/test_decoders.ml +++ b/test/test_decoders.ml @@ -265,3 +265,13 @@ let%test "basic module-wrapped type" = match D.decode_string outer_inner_wrapped_decoder {|{"wrapped":"value"}|} with | Ok { wrapped = "value" } -> true | _ -> false + +type ('a, 'b) double_wrap = { fst : 'a; snd : 'b } [@@deriving decoders] +type double_wrapped = (string, int) double_wrap [@@deriving decoders] + +let%test "double type var" = + match + D.decode_string double_wrapped_decoder {|{"fst":99,"snd":"another"}|} + with + | Ok { fst = 99; snd = "another" } -> true + | _ -> false diff --git a/test/test_encoders.ml b/test/test_encoders.ml index 70b049c..3a005f5 100644 --- a/test/test_encoders.ml +++ b/test/test_encoders.ml @@ -69,3 +69,32 @@ let%test "basic_recursion" = match E.encode_string basic_recur_encoder (Rec (Rec Empty)) with | {|{"Rec":{"Rec":{"Empty":null}}}|} -> true | _ -> false + +type 'a record_wrapper = { wrapped : 'a } [@@deriving encoders] +type int_record_wrapper = int record_wrapper [@@deriving encoders] + +let%test "basic type var" = + match E.encode_string int_record_wrapper_encoder { wrapped = 9876 } with + | {|{"wrapped":9876}|} -> true + | _ -> false + +type ('a, 'b) double_wrap = { fst : 'a; snd : 'b } [@@deriving encoders] +type double_wrapped = (string, int) double_wrap [@@deriving encoders] + +let%test "double type var" = + match E.encode_string double_wrapped_encoder { fst = 9; snd = "10" } with + | {|{"fst":9,"snd":"10"}|} -> true + | _ -> false + +module Outer = struct + module Inner = struct + type t = string [@@deriving encoders] + end +end + +type outer_inner_wrapped = Outer.Inner.t record_wrapper [@@deriving encoders] + +let%test "module wrapped" = + match E.encode_string outer_inner_wrapped_encoder { wrapped = "a thing" } with + | {|{"wrapped":"a thing"}|} -> true + | _ -> false From 470a4e473d664b7624ebfbe530bf2ae99fa88318 Mon Sep 17 00:00:00 2001 From: Ben Bellick Date: Sat, 14 Dec 2024 10:35:45 -0600 Subject: [PATCH 5/6] CI/CD: test that failed tests _are_ raised --- test/test_decoders.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/test_decoders.ml b/test/test_decoders.ml index 77feb8d..a7a2ca0 100644 --- a/test/test_decoders.ml +++ b/test/test_decoders.ml @@ -273,5 +273,5 @@ let%test "double type var" = match D.decode_string double_wrapped_decoder {|{"fst":99,"snd":"another"}|} with - | Ok { fst = 99; snd = "another" } -> true + | Ok { fst = 990; snd = "another" } -> true | _ -> false From 4b9e0d5d4cac4d42e34b4d8f302430347d6f1c10 Mon Sep 17 00:00:00 2001 From: Ben Bellick Date: Sat, 14 Dec 2024 10:39:48 -0600 Subject: [PATCH 6/6] revert bad test as it is caught in CI/CD! --- test/test_decoders.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/test_decoders.ml b/test/test_decoders.ml index a7a2ca0..77feb8d 100644 --- a/test/test_decoders.ml +++ b/test/test_decoders.ml @@ -273,5 +273,5 @@ let%test "double type var" = match D.decode_string double_wrapped_decoder {|{"fst":99,"snd":"another"}|} with - | Ok { fst = 990; snd = "another" } -> true + | Ok { fst = 99; snd = "another" } -> true | _ -> false