Improve name handling and extension handling and return a list of Typ…

…es.c to be emitted that contains comments and deprecation tags.

Changelog.md

@@ -1,5 +1,5 @@
 ## 6.1.0: 2024-04-25
-- Fix name resolution leading to wrongly mapped named
+- Fix name resolution leading to wrongly mapped names
 - Fix codegen bug causing the plugin to reject valid protobuf
 - Add preliminary support for melange though disabling eager
   evaluation of serialize and deserialize functions when not using
@@ -21,7 +21,7 @@
 - [x] Fix file output name if files contains a '-'
 - [x] Resolve bug for Request/Response module aliases leading to
 generating uncompilable code. (#21)
-- [x] Fix codegen bug for messages with out fields and setting
+- [x] Fix codegen bug for messages without fields and setting
 singleton_records = true (#20)
 - [x] In Services, the package field is now correctly set to None if
       the service if not defined in a package scope (#24)

src/ocaml_protoc_plugin/ocaml_protoc_plugin.ml

@@ -1,14 +1,3 @@
-(**/**)
-
-module Serialize = Serialize
-module Deserialize = Deserialize
-module Serialize_json = Serialize_json
-module Deserialize_json = Deserialize_json
-module Spec = Spec
-module Field = Field
-module Merge = Merge
-(**/**)
-
 module Json = Json
 module Reader = Reader
 module Writer = Writer
@@ -17,11 +6,28 @@ module Result = Result
 module Extensions = Extensions
 module Json_options = Json_options
 
+(**/**)
+module Serialize = Serialize
+module Deserialize = Deserialize
+module Serialize_json = Serialize_json
+module Deserialize_json = Deserialize_json
+module Spec = Spec
+module Field = Field
+module Merge = Merge
 
-let apply_lazy f =
+let[@inline] apply_lazy f =
   match Sys.backend_type with
   | Native | Bytecode ->
     f ()
   | Other _ ->
     let f = Lazy.from_fun f in
     fun x -> (Lazy.force f) x
+(**/**)
+
+type test =
+  { a: int; (** This is an int *)
+    b: [`First | `Second]; (** {e b} is [b]
+                               - `First is ok
+                               - `Second is also
+                           *)
+  }

src/plugin/code.ml

@@ -141,3 +141,34 @@ let emit_comment ~(position:[`Leading | `Trailing]) t = function
 let contents t =
   List.map ~f:(Printf.sprintf "%s") (List.rev t.code)
   |> String.concat ~sep:"\n"
+
+(** Emit function comments *)
+let add_arg_doc t
+      ~(position:[`Leading | `Trailing])
+      ?(format:('a -> 'b, unit, string, unit) format4="param %s")
+      ?(comment=[])
+      param_comments =
+
+  let comments = map_comments comment in
+
+  (* Remove parameters with no comments *)
+  let param_comments =
+    List.filter ~f:(fun (_, comments) -> not (List.is_empty comments)) param_comments
+  in
+
+  match comments, param_comments with
+  | [], [] -> ()
+  | [comment], [] ->
+    emit t `None "(** %s *)" (String.trim comment)
+  | comments, param_comments ->
+    if position = `Leading then emit t `None "";
+    emit t `Begin "(**";
+    List.iter ~f:(emit t `None "%s") comments;
+    emit t `None "";
+    List.iter ~f:(fun (param, comments) ->
+      let comments = map_comments comments in
+      emit t `Begin format param;
+      List.iter ~f:(emit t `None "%s") comments;
+      emit t `None "";
+    ) param_comments;
+    emit t `End "*)"

src/plugin/emit.ml

@@ -166,7 +166,7 @@ let emit_extension ~scope ~params ~comment_db ~type_db field =
   (* Get spec and type *)
   let c =
     let params = Parameters.{params with singleton_record = false} in
-    Types.spec_of_field ~params ~syntax:`Proto2 ~scope ~type_db ~map_type:None field
+    Types.spec_of_field ~params ~syntax:`Proto2 ~scope ~type_db ~comment_db ~map_type:None field
   in
   let signature = Code.init () in
   let implementation = Code.init () in
@@ -227,6 +227,20 @@ let rec emit_message ~params ~syntax ~scope ~type_db ~comment_db
   let signature = Code.init () in
   let implementation = Code.init () in
   let deprecated = match options with Some { deprecated; _ } -> deprecated | None -> false in
+  let proto_path = Scope.get_proto_path scope ?name in
+
+  (* Need extensions if specified, added to the list of fields *)
+  let emit_message_type code ~annot = function
+    | _, [] ->
+      Code.emit code `None "type t = unit %s" annot
+    | `Tuple, (types: Types.c list) ->
+      let types = List.map ~f:(fun (c: Types.c) -> Types.string_of_type c.type') types in
+      Code.emit code `None "type t = (%s) %s" (String.concat ~sep:" * " types) annot
+    | `Record, (types: Types.c list) ->
+      Code.emit code `Begin "type t = {";
+      List.iter ~f:(fun (c: Types.c) -> Code.emit code `None "%s:%s;" (Type_db.get_message_field type_db ~proto_path c.name) (Types.string_of_type c.type')) types;
+      Code.emit code `End "} %s" annot;
+  in
 
   let extension_ranges =
     List.map ~f:(function
@@ -270,7 +284,7 @@ let rec emit_message ~params ~syntax ~scope ~type_db ~comment_db
                   default_constructor_sig; default_constructor_impl; merge_impl } =
         Types.make ~params ~syntax ~is_cyclic ~extension_ranges ~scope ~type_db ~comment_db ~fields oneof_decls
       in
-      Code.emit signature `None "type t = %s%s" type' params.annot;
+      emit_message_type signature ~annot:params.annot type';
       Code.emit signature `None "val make: %s" default_constructor_sig;
       Code.emit signature `None "(** Helper function to generate a message using default values *)\n";
 
@@ -296,7 +310,7 @@ let rec emit_message ~params ~syntax ~scope ~type_db ~comment_db
       Code.emit signature `None "(**/**)";
 
       Code.emit implementation `None "let name () = \"%s\"" (Scope.get_proto_path scope);
-      Code.emit implementation `None "type t = %s%s" type' params.annot;
+      emit_message_type implementation ~annot:params.annot type';
 
       Code.emit implementation `None "type make_t = %s" default_constructor_sig;
       Code.emit implementation `None "let make %s" default_constructor_impl;

src/plugin/type_db.ml

@@ -5,10 +5,7 @@ open !MoreLabels
 open !Utils
 open Spec.Descriptor.Google.Protobuf
 
-(* TODO:
-   - Understand proto3_optional flags (Used to map oneof fields for some reason)
-   - Packages should be mapped also, so they can be named correctly
-*)
+
 let sprintf = Printf.sprintf
 
 type oneof = { name: string; constructor_name: string; type_: string option; }
@@ -26,6 +23,9 @@ type element_type =
   | Package
   | Extension
 
+(** Name of extensions field *)
+let extensions_name = "extensions'"
+
 let string_of_element_type = function
   | Message _ -> "Message"
   | Enum _ -> "Enum"
@@ -48,7 +48,7 @@ let add_scope ~proto_name ~ocaml_name { proto_path; ocaml_path; module_name; oca
   { proto_path; ocaml_path; ocaml_name; module_name }
 
 let element_of_message ~mangle_f descriptorproto =
-  let DescriptorProto.{ field = fields; oneof_decl = oneof_decls; options; _ } = descriptorproto in
+  let DescriptorProto.{ field = fields; oneof_decl = oneof_decls; options; extension_range; _ } = descriptorproto in
   let map_type = match options with
     | Some MessageOptions.{ map_entry = Some true; _ } -> Some descriptorproto
     | _ -> None
@@ -68,9 +68,17 @@ let element_of_message ~mangle_f descriptorproto =
   in
 
   let field_name_map =
+    (* If the message specifies extensions, reserve the name here *)
+    let name_map = match List.is_empty extension_range with
+      | true -> StringMap.empty
+      | false ->
+        StringMap.singleton extensions_name extensions_name
+    in
+
     let plain_field_names = List.filter_map ~f:(fun field -> field.FieldDescriptorProto.name) plain_fields in
     let oneof_names = List.filter_map ~f:(fun field -> field.OneofDescriptorProto.name) oneof_decls in
-    Names.create_ocaml_mapping ~mangle_f ~name_f:Names.field_name (plain_field_names @ oneof_names)
+    (* Extend name mapping. The 'extensions_name' should already have been allocated *)
+    Names.create_ocaml_mapping ~name_map ~mangle_f ~name_f:Names.field_name (plain_field_names @ oneof_names)
   in
   (* Need to exclude oneof's where its a proto3 message. In reality, we should not really care. *)
   let oneofs =
@@ -110,11 +118,15 @@ let element_of_message ~mangle_f descriptorproto =
         | Some FieldDescriptorProto.Type.TYPE_MESSAGE -> type_name
         | _ -> None
       in
-      { name; ocaml_name; }, Plain { type_; }
+      { name; ocaml_name; }, Plain { type_ }
     ) plain_fields
   in
-  let fields = plain_fields @ oneofs in
-  (* Interesting that this just returns the scope *)
+  let fields =
+    let fields = plain_fields @ oneofs in
+    match List.is_empty extension_range with
+    | true -> fields
+    | false -> ({ name = extensions_name; ocaml_name = extensions_name }, Plain { type_ = None }) :: fields
+  in
   Message { map_type; fields }
 
 let element_of_enum ~mangle_f EnumDescriptorProto.{ value; _ } =
@@ -154,14 +166,12 @@ let rec traverse_message ~mangle_f ~scope map services descriptorproto =
   (* Scope contains this element *)
   let message_element = element_of_message ~mangle_f descriptorproto in
 
-
   (* Extension name should not interfere with other module names, but should still be uniq *)
   let extension_names = List.filter_map ~f:(fun e -> e.FieldDescriptorProto.name) extensions in
   let name_map =
     Names.create_ocaml_mapping ~name_map ~mangle_f ~name_f:Names.module_name extension_names
   in
 
-  (* Add extensions *)
   let map =
     List.fold_left ~init:map ~f:(fun map extension ->
       let proto_name = Option.value_exn ~message:"Enums must have a name" extension.FieldDescriptorProto.name in
@@ -278,33 +288,19 @@ let make_module_name ~prefix_module_names ?package name =
   in
   Names.module_name_of_proto ?package name
 
-let dump { map; cyclic_set; file_map } =
-  ignore cyclic_set;
-  StringMap.iter ~f:(fun ~key ~data -> Printf.eprintf "Module %s: %s\n" key data) file_map;
-  StringMap.iter ~f:(fun ~key ~data -> Printf.eprintf "Type: %s: %s\n" key (string_of_element_type (snd data))) map;
-  (*
-  StringMap.iter ~f:(fun ~key ~data:{ module_name; ocaml_name; element_type } ->
-    let element_str = match element_type with
-      | Message { is_map; fields; _ } ->
-        List.map ~f:(function
-          | { name; _ }, Plain { type_ } -> sprintf "(%s, %s)" name (Option.value ~default:"<none>" type_)
-          | { name; _ }, Oneof _ -> name
-        ) fields
-        |> String.concat ~sep:"; "
-        |> sprintf "is_map: %b, [ %s ]" is_map
-      | _ -> ""
-    in
-    match StringSet.mem key cyclic_set with
-    | true -> Printf.eprintf "Cyclic: %s -> %s.%s : %s\n" key module_name ocaml_name element_str
-    | false -> ()
-  ) map;
-  StringMap.iter ~f:(fun ~key ~data:{ module_name; ocaml_name; element_type } ->
+let dump { map; cyclic_set = _; file_map } =
+  let eprintf = Printf.eprintf in
+
+  StringMap.iter ~f:(fun ~key ~data -> eprintf "Module %s: %s\n" key data) file_map;
+  (* Just traverse everything *)
+  StringMap.iter ~f:(fun ~key:proto_path ~data:({module_name; _ }, element_type) ->
     match element_type with
-    | Message { is_map = true; _ } -> Printf.eprintf "Map: %s -> %s#%s\n" key module_name ocaml_name
+    | Message { fields; _ } ->
+      List.iter ~f:(fun ({name; ocaml_name }, _field) ->
+        eprintf "%s%s.%s -> %s\n" module_name proto_path name ocaml_name
+      ) fields
     | _ -> ()
-   ) map;
-  *)
-  ()
+  ) map
 
 let init ~prefix_module_names (files : FileDescriptorProto.t list) =
   let map, file_map = List.fold_left ~init:(StringMap.empty, StringMap.empty) ~f:(
@@ -316,8 +312,6 @@ let init ~prefix_module_names (files : FileDescriptorProto.t list) =
       (map, file_map)
   ) files in
 
-
-
   let cyclic_set = create_cyclic_set map in
   let t = { map; cyclic_set; file_map } in
   if false then dump t;