Merge pull request #10 from benbellick/type-vars

src/decoders_deriver.ml

@@ -15,32 +15,25 @@ 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 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_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 ().
@@ -104,7 +97,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) =
@@ -113,7 +106,19 @@ 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 = 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
+      (* 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)
@@ -284,7 +289,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
@@ -301,7 +306,8 @@ 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
     | Nonrecursive -> []
@@ -314,7 +320,25 @@ 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
+      (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
@@ -326,12 +350,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)
@@ -356,18 +380,18 @@ 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
       let imple_as_lambda = pexp_fun_multiarg ~loc imple args in
       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 =
@@ -409,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 ->

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));
       ]

test/test_decoders.ml

@@ -49,6 +49,9 @@ type a1 = { l : b1 option; m : c1 option }
 and b1 = { n : c1 }
 and c1 = { o : a1 } [@@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
   | Ok i -> i = 1234
@@ -233,3 +236,42 @@ 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
+
+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
+
+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

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