Add option -j-gen-modules to generate JSON generic submodules → #416

atdgen/bin/ag_main.ml

@@ -62,6 +62,7 @@ let main () =
   let out_prefix = ref None in
   let mode = ref (None : mode option) in
   let std_json = ref false in
+  let add_generic_modules = ref false in
   let j_preprocess_input = ref None in
   let j_defaults = ref false in
   let unknown_field_handler = ref None in
@@ -184,6 +185,12 @@ let main () =
           refuse to print NaN and infinities (implying -json mode
           unless another mode is specified).";
 
+    "-j-gen-modules",
+    Arg.Unit (fun () ->
+                add_generic_modules := true),
+    "
+          Add genericity-friendly modules to -j output.";
+
     "-std-json",
     Arg.Unit (fun () ->
                 std_json := true),
@@ -402,6 +409,7 @@ Recommended usage: %s (-t|-b|-j|-v|-dep|-list|-mel) example.atd" Sys.argv.(0) in
                   ~std: !std_json
                   ~unknown_field_handler: !unknown_field_handler
                   ~preprocess_input: !j_preprocess_input
+                  ~add_generic_modules: !add_generic_modules
             | V | Validate ->
                 Ov_emit.make_ocaml_files
             | Melange ->

atdgen/src/oj_emit.ml

@@ -34,40 +34,35 @@ type param = {
 
 }
 
-let make_ocaml_json_intf ~with_create buf deref defs =
-  List.concat_map snd defs
-  |> List.filter Ox_emit.include_intf
-  |> List.iter (fun x ->
-    let s = x.def_name in
-    let full_name = Ox_emit.get_full_type_name x in
-    let writer_params =
-      String.concat "" (
-        List.map
-          (fun s -> sprintf "\n  (Buffer.t -> '%s -> unit) ->" s)
-          x.def_param
-      )
-    in
-    let reader_params =
-      String.concat "" (
-        List.map
-          (fun s ->
-             sprintf "\n  (Yojson.Safe.lexer_state -> \
-                      Lexing.lexbuf -> '%s) ->" s)
-          x.def_param
-      )
-    in
+let writer_parameters params =
+  String.concat "" (
+    List.map
+      (fun s -> sprintf "\n  (Buffer.t -> '%s -> unit) ->" s)
+      params
+  )
+let reader_parameters params =
+  String.concat "" (
+    List.map
+      (fun s ->
+         sprintf "\n  (Yojson.Safe.lexer_state -> \
+                  Lexing.lexbuf -> '%s) ->" s)
+      params
+  )
+
+let val_write buf fun_name writer_params full_name short_name =
     bprintf buf "\
-val write_%s :%s
+val %s :%s
   Buffer.t -> %s -> unit
   (** Output a JSON value of type {!type:%s}. *)
 
 "
-      s writer_params
+      fun_name writer_params
       full_name
-      s;
+      short_name
 
+let val_string_of buf fun_name writer_params full_name short_name =
     bprintf buf "\
-val string_of_%s :%s
+val %s :%s
   ?len:int -> %s -> string
   (** Serialize a value of type {!type:%s}
       into a JSON string.
@@ -76,29 +71,48 @@ val string_of_%s :%s
                  Default: 1024. *)
 
 "
-      s writer_params
+      fun_name writer_params
       full_name
-      s;
+      short_name
 
+let val_read buf fun_name reader_params full_name short_name =
     bprintf buf "\
-val read_%s :%s
+val %s :%s
   Yojson.Safe.lexer_state -> Lexing.lexbuf -> %s
   (** Input JSON data of type {!type:%s}. *)
 
 "
-      s reader_params
+      fun_name reader_params
       full_name
-      s;
+      short_name
 
+let val_of_string buf fun_name reader_params full_name short_name =
     bprintf buf "\
-val %s_of_string :%s
+val %s :%s
   string -> %s
   (** Deserialize JSON data of type {!type:%s}. *)
 
 "
-      s reader_params
+      fun_name reader_params
       full_name
-      s;
+      short_name
+
+let make_ocaml_json_intf ~with_create buf deref defs =
+  List.concat_map snd defs
+  |> List.filter Ox_emit.include_intf
+  |> List.iter (fun x ->
+    let s = x.def_name in
+    let full_name = Ox_emit.get_full_type_name x in
+    let writer_params = writer_parameters x.def_param in
+    let reader_params = reader_parameters x.def_param in
+    val_write buf (sprintf "write_%s" s)
+      writer_params full_name s;
+    val_string_of buf (sprintf "string_of_%s" s)
+      writer_params full_name s;
+    val_read buf (sprintf "read_%s" s)
+      reader_params full_name s;
+    val_of_string buf (sprintf "%s_of_string" s)
+      reader_params full_name s;
     Ox_emit.maybe_write_creator_intf ~with_create deref buf x
   )
 
@@ -1323,6 +1337,50 @@ let make_ml
       buf deref defs;
   Buffer.contents buf
 
+let make_extra_generic_modules definitions =
+  let ml = Buffer.create 42 in
+  let mli = Buffer.create 42 in
+  let oof buf fmt = Format.kasprintf (Buffer.add_string buf) fmt in
+  let mlf fmt = oof ml fmt in
+  let mlif fmt = oof mli fmt in
+  let bothf fmt=
+    Format.kasprintf (fun s -> 
+      Buffer.add_string ml s; Buffer.add_string mli s) fmt in
+  bothf "\n\n(** {3 Generic Modules } *)\n";
+  let make_module name params =
+    bothf "module %s" (String.capitalize_ascii name);
+    mlf " = struct\n";
+    mlif " : sig\n";
+    let type_params =
+      List.map (sprintf "'%s") params |> String.concat ", " in
+    let type_params_prefix =
+      match params with [] -> "" | _ -> sprintf "(%s) " type_params in
+    bothf "type nonrec %st = %s%s\n" type_params_prefix type_params_prefix name;
+    mlf "let write = write_%s\n" name;
+    mlf "let read = read_%s\n" name;
+    mlf "let to_string = string_of_%s\n" name;
+    mlf "let of_string = %s_of_string\n" name;
+    val_write mli (sprintf "write" ) (writer_parameters params) 
+      (type_params_prefix ^ name) name;
+    val_string_of mli (sprintf "to_string" ) (writer_parameters params) 
+      (type_params_prefix ^ name) name;
+    val_read mli (sprintf "read" ) (reader_parameters params) 
+      (type_params_prefix ^ name) name;
+    val_of_string mli (sprintf "of_string" ) (reader_parameters params) 
+      (type_params_prefix ^ name) name;
+    bothf "end\n"
+  in
+  List.iter
+    (fun (_, body) ->
+      List.iter
+        (fun (Atd.Ast.Type (_, (name, params, _), type_expr)) ->
+          match type_expr with
+          | Name (_, (_, "abstract", _), _) -> ()
+          | _ -> make_module name params)
+        body)
+    definitions;
+  (`Ml (Buffer.contents ml), `Mli (Buffer.contents mli))
+
 let make_ocaml_files
     ~opens
     ~with_typedefs
@@ -1338,6 +1396,7 @@ let make_ocaml_files
     ~preprocess_input
     ~ocaml_version
     ~pp_convs
+    ~add_generic_modules
     atd_file out =
   let ((head, m0), _) =
     match atd_file with
@@ -1394,4 +1453,10 @@ let make_ocaml_files
       ~ocaml_version
       ocaml_typedefs (Mapping.make_deref defs) defs
   in
+  let mli, ml =
+    if not add_generic_modules then mli, ml
+    else
+      let `Ml extra_ml, `Mli extra_mli = make_extra_generic_modules m1 in
+      (mli ^ extra_mli, ml ^ extra_ml)
+  in
   Ox_emit.write_ocaml out mli ml

atdgen/src/oj_emit.mli

@@ -15,6 +15,7 @@ val make_ocaml_files
   -> preprocess_input:string option
   -> ocaml_version:(int * int) option
   -> pp_convs:Ocaml.pp_convs
+  -> add_generic_modules: bool
   -> string option
   -> Ox_emit.target
   -> unit

atdgen/test/dune

@@ -66,7 +66,7 @@
 (rule
  (targets test_int_with_string_repr_j.ml test_int_with_string_repr_j.mli)
  (deps    test_int_with_string_repr.atd)
- (action  (run %{bin:atdgen} -j %{deps})))
+ (action  (run %{bin:atdgen} -j -j-gen-modules %{deps})))
 
 (rule
  (alias runtest)
@@ -94,7 +94,7 @@
  (targets test_ambiguous_record_j.ml test_ambiguous_record_j.mli)
  (deps    test_ambiguous_record.atd)
  (action
-  (run %{bin:atdgen} -json -std-json -o test_ambiguous_record_j -open Test_ambiguous_record_t -ntd %{deps})))
+  (run %{bin:atdgen} -json -std-json -j-gen-modules -o test_ambiguous_record_j -open Test_ambiguous_record_t -ntd %{deps})))
 
 (rule
  (targets test_ambiguous_variant_t.ml test_ambiguous_variant_t.mli)
@@ -106,7 +106,7 @@
  (targets test_ambiguous_variant_j.ml test_ambiguous_variant_j.mli)
  (deps    test_ambiguous_variant.atd)
  (action
-  (run %{bin:atdgen} -j -j-std %{deps})))
+  (run %{bin:atdgen} -j -j-std -j-gen-modules %{deps})))
 
 (rule
  (targets test_polymorphic_wrap_t.ml test_polymorphic_wrap_t.mli)
@@ -118,7 +118,7 @@
  (targets test_polymorphic_wrap_j.ml test_polymorphic_wrap_j.mli)
  (deps    test_polymorphic_wrap.atd)
  (action
-  (run %{bin:atdgen} -json -std-json -o test_polymorphic_wrap_j %{deps})))
+  (run %{bin:atdgen} -json -std-json -j-gen-modules -o test_polymorphic_wrap_j %{deps})))
 
 (rule
  (alias runtest)
@@ -343,7 +343,7 @@
 (rule
  (targets test_abstract_j.ml test_abstract_j.mli)
  (deps    test_abstract.atd)
- (action  (run %{bin:atdgen} -j %{deps})))
+ (action  (run %{bin:atdgen} -j -j-gen-modules %{deps})))
 
 (rule
  (targets test_abstract_v.ml test_abstract_v.mli)

atdgen/test/test_abstract_j.expected.ml

@@ -75,3 +75,13 @@ let read_abs1 read__x = (
 )
 let abs1_of_string read__x s =
   read_abs1 read__x (Yojson.Safe.init_lexer ()) (Lexing.from_string s)
+
+
+(** {3 Generic Modules } *)
+module Any_items = struct
+type nonrec t = any_items
+let write = write_any_items
+let read = read_any_items
+let to_string = string_of_any_items
+let of_string = any_items_of_string
+end

atdgen/test/test_abstract_j.expected.mli

@@ -99,3 +99,29 @@ val abs1_of_string :
   string -> 'x abs1
   (** Deserialize JSON data of type {!type:abs1}. *)
 
+
+
+(** {3 Generic Modules } *)
+module Any_items : sig
+type nonrec t = any_items
+val write :
+  Buffer.t -> any_items -> unit
+  (** Output a JSON value of type {!type:any_items}. *)
+
+val to_string :
+  ?len:int -> any_items -> string
+  (** Serialize a value of type {!type:any_items}
+      into a JSON string.
+      @param len specifies the initial length
+                 of the buffer used internally.
+                 Default: 1024. *)
+
+val read :
+  Yojson.Safe.lexer_state -> Lexing.lexbuf -> any_items
+  (** Input JSON data of type {!type:any_items}. *)
+
+val of_string :
+  string -> any_items
+  (** Deserialize JSON data of type {!type:any_items}. *)
+
+end

atdgen/test/test_ambiguous_record_j.expected.ml

@@ -328,3 +328,20 @@ let create_ambiguous
     ambiguous = ambiguous;
     not_ambiguous1 = not_ambiguous1;
   }
+
+
+(** {3 Generic Modules } *)
+module Ambiguous' = struct
+type nonrec t = ambiguous'
+let write = write_ambiguous'
+let read = read_ambiguous'
+let to_string = string_of_ambiguous'
+let of_string = ambiguous'_of_string
+end
+module Ambiguous = struct
+type nonrec t = ambiguous
+let write = write_ambiguous
+let read = read_ambiguous
+let to_string = string_of_ambiguous
+let of_string = ambiguous_of_string
+end

atdgen/test/test_ambiguous_variant_j.expected.ml

@@ -183,3 +183,20 @@ let read_ambiguous = (
 )
 let ambiguous_of_string s =
   read_ambiguous (Yojson.Safe.init_lexer ()) (Lexing.from_string s)
+
+
+(** {3 Generic Modules } *)
+module Ambiguous' = struct
+type nonrec t = ambiguous'
+let write = write_ambiguous'
+let read = read_ambiguous'
+let to_string = string_of_ambiguous'
+let of_string = ambiguous'_of_string
+end
+module Ambiguous = struct
+type nonrec t = ambiguous
+let write = write_ambiguous
+let read = read_ambiguous
+let to_string = string_of_ambiguous
+let of_string = ambiguous_of_string
+end