Merge pull request #26 from andersfugmann/andersfugmann/add_doc_comments

Copy comments from the protobuf file into autogenerated code

Changelog.md

@@ -5,6 +5,7 @@
 - [x] Support special json mapping for google types (#9)
 - [x] Add deprecation annotations for deprecated fields, services etc (#8)
 - [x] Add option to prefix generated files with their package name
+- [x] Copy documentation from proto files into generated ocaml bindings
 
 ### Bug fixes
 - [x] Fix file output name if files contains a '-'

src/ocaml_protoc_plugin/json.ml

@@ -11,7 +11,7 @@ type t = [
   | `List of t list
 ]
 
-let rec to_string = function
+let rec to_string: t -> string = function
   | `Null -> "null"
   | `Bool b -> string_of_bool b
   | `Int i -> string_of_int i

src/plugin/code.ml

@@ -1,4 +1,6 @@
-open StdLabels
+open !StdLabels
+open !MoreLabels
+open !Utils
 
 type t = {
   mutable indent : string;
@@ -13,34 +15,71 @@ let decr t =
     t.indent <- String.sub ~pos:0 ~len:(String.length t.indent - 2) t.indent
   | false -> failwith "Cannot decr indentation level at this point"
 
-let emit t indent fmt =
-  let trim_end ~char s =
-    let len = String.length s in
-    let rcount s =
-      let rec inner = function
-        | 0 -> len
-        | n when s.[n - 1] = char -> inner (n - 1)
-        | n -> len - n
+(** Merge groups when the list groups ends with a line that starts with a '-' *)
+let rec merge_list_groups = function
+  | (false, l1) :: (true, l2) :: xs ->
+    begin match List.rev l1 with
+    | s :: _ when String.starts_with_regex ~regex:"[ ]*- " s ->
+      (false, l1 @ l2) :: merge_list_groups xs
+    | _ -> (false, l1) :: (true, l2) :: merge_list_groups xs
+    end
+  | x :: xs ->
+    x :: merge_list_groups xs
+  | [] -> []
+
+let remove_trailing_empty_lines lines =
+  lines
+  |> List.rev
+  |> List.drop_while ~f:((=) "")
+  |> List.rev
+
+let escape_comment s =
+  String.to_seq s
+  |> Seq.map (function
+    | '{' | '}' | '[' | ']' | '@' | '\\' as ch -> Printf.sprintf "\\%c" ch
+    | ch -> Printf.sprintf "%c" ch
+  )
+  |> List.of_seq
+  |> String.concat ~sep:""
+
+
+let map_comments comments =
+  comments
+  |> String.concat ~sep:"\n\n"
+  |> String.split_on_char ~sep:'\n'
+  |> List.map ~f:(String.trim_end ~chars:" \n\t")
+  |> List.group ~f:(fun s -> String.starts_with ~prefix:"  " s && not (String.starts_with_regex ~regex:"[ ]*- " s))
+  |> merge_list_groups
+  |> List.map ~f:(function
+    | (false, lines) ->
+      lines
+      |> List.map ~f:String.trim
+      |> remove_trailing_empty_lines
+      |> List.map ~f:escape_comment
+    | (true, lines) ->
+      let lines =
+        lines
+        |> List.map ~f:(String.replace ~substring:"v}" ~f:(fun _ -> "v\\}"))
+        |> remove_trailing_empty_lines
       in
-      inner len
-    in
-    match rcount s with
-    | 0 -> s
-    | n -> String.sub ~pos:0 ~len:(String.length s - n) s
-  in
+      (* TODO: Remove indentation *)
+      "{v" :: lines @ ["v}"]
+  )
+  |> List.flatten
+  |> List.rev
+  |> List.drop_while ~f:(fun x -> x = "")
+  |> List.rev
+
+let emit t indent fmt =
   let prepend s =
-    match String.split_on_char ~sep:'\n' s with
-    | line :: lines ->
+    String.split_on_char ~sep:'\n' s
+    |> List.iter ~f:(fun line ->
       (* Replace tabs with indent *)
       let line =
         "" :: String.split_on_char ~sep:'\t' line
         |> String.concat ~sep:t.indent
       in
-      t.code <- (trim_end ~char:' ' line) :: t.code;
-      incr t;
-      List.iter lines ~f:(fun line -> t.code <- (trim_end ~char:' ' (t.indent ^ line)) :: t.code);
-      decr t;
-    | [] -> ()
+      t.code <- (String.trim_end ~chars:" " line) :: t.code);
   in
   let emit s =
     match indent with
@@ -70,7 +109,34 @@ let append_deprecaton_if ~deprecated level str =
       | `Item -> "@@"
       | `Floating -> "@@@"
     in
-    Printf.sprintf "%s[%socaml.alert protobuf \"Deprecated global\"]" str level
+    Printf.sprintf "%s[%socaml.alert protobuf \"Marked as deprecated in the .proto file\"]" str level
+
+let append_comments ~comments str =
+  let comment_str =
+    map_comments comments
+    |> String.concat ~sep:"\n"
+    |> String.trim
+  in
+  match List.is_empty comments with
+  | true -> str
+  | false ->
+    Printf.sprintf "%s(** %s *)" str comment_str
+
+let emit_comment ~(position:[`Leading | `Trailing]) t = function
+  | [] -> ()
+  | comments ->
+    if position = `Leading then emit t `None "";
+    let comments = map_comments comments in
+    let () =
+      match comments with
+      | [ comment ] -> emit t `None "(** %s *)" (String.trim comment)
+      | comments ->
+        emit t `Begin "(**";
+        List.iter ~f:(emit t `None "%s") comments;
+        emit t `End "*)";
+    in
+    (* if position = `Trailing then emit t `None ""; (* Dont think this is needed *) *)
+    ()
 
 let contents t =
   List.map ~f:(Printf.sprintf "%s") (List.rev t.code)

src/plugin/comment_db.ml

@@ -0,0 +1,157 @@
+open StdLabels
+open MoreLabels
+open Spec.Descriptor.Google.Protobuf
+
+type element =
+  | Message | Field
+  | Enum | Enum_value
+  | Oneof
+  | Service | Method
+  | Extension
+  | File
+  | Option
+  | Unknown of element * int
+
+let rec string_of_element = function
+  | Message -> "Message"
+  | Field -> "Field"
+  | Enum -> "Enum"
+  | Enum_value -> "Enum_value"
+  | Oneof -> "Oneof"
+  | Service -> "Service"
+  | Method -> "Method"
+  | Extension -> "Extension"
+  | File -> "File"
+  | Option -> "Option"
+  | Unknown (ctx, n) -> Printf.sprintf "Unknown(%s, %d)" (string_of_element ctx) n
+
+let element_of_int ~context = function
+  | 4 when context = File -> Message
+  | 8 when context = File -> Option
+  | 3 when context = Message -> Message
+
+  | 5 when context = File -> Enum
+  | 4 when context = Message -> Enum
+  | 2 when context = Enum -> Enum_value
+
+  | 8 when context = Message -> Oneof
+  | 2 when context = Message -> Field
+
+  | 6 when context = File -> Service
+  | 2 when context = Service -> Method
+
+  | 7 when context = File -> Extension
+  | 6 when context = Message -> Extension
+
+  | n -> Unknown (context, n)
+
+type path = (element * int) list
+
+let string_of_path path =
+  List.map ~f:(fun (e, i) ->
+    let e_str = string_of_element e in
+    Printf.sprintf "(%s, %d)" e_str i
+  ) path
+  |> String.concat ~sep:"; "
+  |> Printf.sprintf "[ %s ]"
+
+
+type comment = string option
+type comments = { leading: comment; trailing: comment; detatched: string list }
+
+module Code_info_map = Map.Make(struct type t = path let compare = compare end)
+type code_info_map = comments Code_info_map.t
+
+type t = comments Utils.StringMap.t
+
+let make_code_info_map: SourceCodeInfo.t option -> code_info_map = fun source_code_info ->
+  let source_code_info = Option.value ~default:[] source_code_info in
+
+  let rec map_location ~context = function
+    | field_id :: number :: rest ->
+      let element = element_of_int ~context field_id in
+      (element, number) :: map_location ~context:element rest
+    | [ field_id ] -> [ Field, field_id ]
+    | [] -> []
+  in
+
+  let map =
+    List.fold_left ~init:Code_info_map.empty ~f:(fun db location ->
+      match location with
+      | SourceCodeInfo.Location.{ leading_comments = None; trailing_comments = None; leading_detached_comments = []; _ } -> db
+      | SourceCodeInfo.Location.{ leading_comments = leading; trailing_comments = trailing; leading_detached_comments = detatched; _ } ->
+        let path = map_location ~context:File location.SourceCodeInfo.Location.path in
+        let element = { leading; trailing; detatched } in
+        Code_info_map.add ~key:path ~data:element db
+    ) source_code_info
+  in
+  map
+
+let concat_mapi ~f lst =
+  let vs = List.mapi ~f lst in
+  List.concat vs
+
+let prepend_path ~tpe ~index ~name lst =
+  let path = tpe, index in
+  (path :: [], name) :: List.map ~f:(fun (p, n) ->
+    path :: p, Printf.sprintf "%s.%s" name n
+  ) lst
+
+let traverse_field index FieldDescriptorProto.{ name; _ } =
+  let name = Option.value_exn name in
+  [Field, index], name
+
+let traverse_extension index FieldDescriptorProto.{ name; _ } =
+  let name = Option.value_exn name in
+  [Extension, index], name
+
+let traverse_service_method index MethodDescriptorProto.{ name; _ } =
+  let name = Option.value_exn name in
+  [Method, index], name
+
+let traverse_service index ServiceDescriptorProto.{ name; method'; _ } =
+  let name = Option.value_exn name in
+  let values = List.mapi ~f:traverse_service_method method' in
+  prepend_path ~tpe:Enum ~index ~name values
+
+let traverse_enum_value index EnumValueDescriptorProto.{ name; _ } =
+  let name = Option.value_exn name in
+  [Enum_value, index], name
+
+let traverse_enum_type index EnumDescriptorProto.{ name; value; _ } =
+  let name = Option.value_exn name in
+  let values = List.mapi ~f:traverse_enum_value value in
+  prepend_path ~tpe:Enum ~index ~name values
+
+let rec traverse_message index DescriptorProto.{ name; field; nested_type; enum_type; extension; _ } =
+  let name = Option.value_exn name in
+  let fields = List.mapi ~f:traverse_field field in
+  let sub_messages = concat_mapi ~f:traverse_message nested_type in
+  let extensions = List.mapi ~f:traverse_extension extension in
+  let enums = concat_mapi ~f:traverse_enum_type enum_type in
+
+  (fields @ sub_messages @ extensions @ enums)
+  |> prepend_path ~tpe:Message ~index ~name
+
+let traverse FileDescriptorProto.{ package; enum_type; service; extension; message_type; _ } =
+  let package = match package with
+    | Some package -> Printf.sprintf ".%s" package
+    | None -> ""
+  in
+  let enums = concat_mapi ~f:traverse_enum_type enum_type in
+  let services = concat_mapi ~f:traverse_service service in
+  let messages = concat_mapi ~f:traverse_message message_type in
+  let extensions = List.mapi ~f:traverse_extension extension in
+  (enums @ services @ messages @ extensions )
+  |> List.map ~f:(fun (path, name) -> path, Printf.sprintf "%s.%s" package name)
+
+
+(** Traverse the full filedescriptor proto to construct proto_name -> comments mapping *)
+let make: FileDescriptorProto.t -> t = fun filedescriptor ->
+  let code_info_map = make_code_info_map filedescriptor.source_code_info in
+  traverse filedescriptor
+  |> List.fold_left ~init:Utils.StringMap.empty ~f:(fun t (path, name) ->
+    match Code_info_map.find_opt path code_info_map with
+    | Some comments -> Utils.StringMap.add ~key:name ~data:comments t
+    | None -> t
+  )

src/plugin/dune

@@ -1,7 +1,7 @@
 (executable
  (name protoc_gen_ocaml)
  (public_name protoc-gen-ocaml)
- (libraries spec)
+ (libraries spec str)
  (package ocaml-protoc-plugin)
  (instrumentation (backend bisect_ppx))
 )