Wip

src/plugin/names.ml

@@ -1,4 +1,6 @@
-open StdLabels
+open !StdLabels
+open !MoreLabels
+open !Utils
 
 type char_type = Lower | Upper | Neither
 
@@ -68,3 +70,47 @@ let has_mangle_option options =
     |> function
     | Some v -> v
     | None -> false
+
+(** Create a map: proto_name -> ocaml_name.
+    Mapping is done in multiple passes to prioritize which mapping wins in case of name clashes
+*)
+let create_name_map ~standard_f ~mangle_f names =
+  let rec uniq_name names ocaml_name =
+    match List.assoc_opt ocaml_name names with
+    | None -> ocaml_name
+    | Some _ -> uniq_name names (ocaml_name ^ "'")
+  in
+  let names =
+    List.map ~f:(fun name ->
+      let mangle_name = mangle_f name in
+      let standard_name = standard_f name in
+      (name, mangle_name, standard_name)
+    ) names
+  in
+  let standard_name_map =
+    let inject ~f map =
+      List.fold_left ~init:map ~f:(fun map (name, mangled_name, standard_name) ->
+        match f name mangled_name standard_name with
+        | true when StringMap.mem mangled_name map -> map
+        | true -> StringMap.add ~key:mangled_name ~data:name map
+        | false -> map
+      ) names
+    in
+    StringMap.empty
+    |> inject ~f:(fun name mangled_name _standard_name -> String.equal mangled_name name)
+    |> inject ~f:(fun _name mangled_name standard_name -> String.equal mangled_name standard_name)
+    |> inject ~f:(fun name mangled_name _standard_name -> String.equal (String.lowercase_ascii mangled_name) (String.lowercase_ascii name))
+    |> inject ~f:(fun _name mangled_name standard_name -> String.equal (String.lowercase_ascii mangled_name) (String.lowercase_ascii standard_name))
+  in
+  List.fold_left ~init:[] ~f:(fun names (proto_name, ocaml_name, _) ->
+    let ocaml_name =
+      match StringMap.find_opt ocaml_name standard_name_map with
+      | Some name when String.equal name proto_name -> ocaml_name
+      | Some _ -> ocaml_name ^ "'"
+      | None -> ocaml_name
+    in
+    (uniq_name names ocaml_name, proto_name) :: names
+  ) names
+  |> List.fold_left ~init:StringMap.empty ~f:(fun map (ocaml_name, proto_name) ->
+    StringMap.add ~key:proto_name ~data:ocaml_name map
+  )

src/plugin/option.ml

@@ -27,4 +27,10 @@ let bind ~f = function
 
 let some v = Some v
 
+let is_some = function
+  | Some _ -> true
+  | None -> false
+
+let is_none v = not (is_some v)
+
 let none = None

src/plugin/type_map.ml

@@ -0,0 +1,176 @@
+(** Module to create mapping between proto names 'X.Y.Z' to ocaml names *)
+open !StdLabels
+open !MoreLabels
+open !Utils
+open Spec.Descriptor.Google.Protobuf
+
+
+let sprintf = Printf.sprintf
+
+type oneof = { name: string; constructor_name: string; type_: string option; }
+type field_type = Plain of { type_: string option }
+                | Oneof of oneof list
+
+type constructor =  { name: string; ocaml_name: string }
+type field = { name: string; ocaml_name: string; type_: field_type }
+
+(* The map has: proto_type -> ocaml_module * ocaml_name * element_type *)
+
+type element_type =
+  | Message of field list
+  | Enum of constructor list
+  | Service
+  | Method
+
+
+(* The map has: proto_type -> ocaml_module * ocaml_name * element_type *)
+
+type element = { ocaml_module: string; (* Module in which the definition resides - derived from the proto name *)
+                 ocaml_name: string; (* Fully qualified ocaml name of the module; e.g. My_module.Sub_module.X *)
+                 element_type: element_type;
+               }
+
+type t = element StringMap.t
+
+
+let module_name_of_proto ?package proto_file =
+  Filename.chop_extension proto_file
+  |> Filename.basename
+  |> (
+    match package with
+    | Some package -> Printf.sprintf "%s_%s" package
+    | None -> fun s -> s
+  )
+  |> String.capitalize_ascii
+  |> String.map ~f:(function '-' | '.' -> '_' | c -> c)
+
+type scope = { proto_path: string; ocaml_path: string; module_name: string }
+
+let add_scope ~proto_name ~ocaml_name { proto_path; ocaml_path; module_name } =
+  { proto_path = sprintf "%s.%s" proto_path proto_name;
+    ocaml_path = sprintf "%s.%s" ocaml_path ocaml_name;
+    module_name }
+
+let element_of_message ~mangle_f ~scope fields oneof_decls =
+  (* TODO: Old code also branched on FieldDescriptorProto.{ proto3_optional = Some true; _ } *)
+  let plain_fields = List.filter ~f:(fun FieldDescriptorProto.{ oneof_index; _ } -> Option.is_none oneof_index) fields in
+  let field_name_map =
+    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_name_map
+      ~standard_f:(Names.field_name ~mangle_f:(fun x -> x))
+      ~mangle_f:(Names.field_name ~mangle_f)
+      (plain_field_names @ oneof_names)
+  in
+  let oneofs =
+    List.mapi ~f:(fun i OneofDescriptorProto.{ name; _ } ->
+      let name = Option.value_exn ~message:"Oneof field must have a name" name in
+      (* Get all the fields *)
+      let oneof_fields =
+        List.filter ~f:(function
+          | FieldDescriptorProto.{ oneof_index = Some i'; _ } -> i = i'
+          | FieldDescriptorProto.{ oneof_index = None; _ } -> false
+        ) fields
+      in
+      let oneof_name_map =
+        List.filter_map ~f:(fun field -> field.FieldDescriptorProto.name) oneof_fields
+        |> Names.create_name_map
+             ~standard_f:(Names.poly_constructor_name ~mangle_f:(fun x -> x))
+             ~mangle_f:(Names.poly_constructor_name ~mangle_f)
+      in
+      let oneofs =
+        List.map ~f:(fun FieldDescriptorProto.{ name; type_name; type'; _ } ->
+          let name = Option.value_exn ~message:"All fields should have a name" name in
+          let type_ = match type' with
+            | Some FieldDescriptorProto.Type.TYPE_MESSAGE -> type_name
+            | _ -> None
+          in
+          let constructor_name = StringMap.find name oneof_name_map in
+          { name; constructor_name; type_; }
+        ) oneof_fields
+      in
+      let ocaml_name = StringMap.find name field_name_map in
+      { name; ocaml_name; type_ = Oneof oneofs }
+    ) oneof_decls
+  in
+  let plain_fields =
+    List.map ~f:(fun FieldDescriptorProto.{ name; type_name; type'; _ } ->
+      let name = Option.value_exn ~message:"All fields should have a name" name in
+      let ocaml_name = StringMap.find name field_name_map in
+      let type_ = match type' with
+        | Some FieldDescriptorProto.Type.TYPE_MESSAGE -> type_name
+        | _ -> None
+      in
+      { name; ocaml_name; type_ = Plain { type_; } }
+    ) plain_fields
+  in
+  let fields = plain_fields @ oneofs in
+  { ocaml_module = scope.ocaml_module;
+    ocaml_name = scope.ocaml_name;
+    element_type = Message fields;
+  }
+
+let traverse_message ~mangle_f ~scope map messages =
+  (* Assign a name for all the messages *)
+  let names =
+    let messages =
+      List.map ~f:(function
+        | DescriptorProto.{ name = Some name; _ } as desciptor -> name, descriptor
+        | DescriptorProto.{ name = None; _ } -> failwith "All messages must have a name"
+      )
+    in
+    let names, _ = List.split messages in
+    let name_map =
+      Names.create_name_map
+        ~standard_f:(Names.module_name ~mangle_f:(fun x -> x))
+        ~mangle_f:(Names.module_name ~mangle_f) names
+    in
+    List.fold_left ~init:map ~f:(fun (proto_name, desciptor) ->
+      let ocaml_name = StringMap.find proto_name in
+      let scope = add_scope ~proto_name ~ocaml_name scope in
+
+      (* Construct the element here *)
+      (* We need to create a mapping for all fields *)
+      (* And collect dependencies *)
+      map
+
+
+      scope, desciptor
+
+
+
+
+
+
+
+  (* When traversing into a scope
+  let scope' = add_scope name
+  let message_element = { ocaml_module
+
+let traverse_file ~prefix_module_names ~mangle_f map FileDescriptorProto.{ name; message_type = messages; package; enum_type = enums; service = services; extension = extensions; _ } =
+  let name = Option.value_exn ~message:"All files must have a name" name in
+  (* Name is the proto name *)
+  let module_name =
+    let package = match prefix_module_names with
+      | false -> None
+      | true -> map.package
+    in
+    module_name_of_proto ?package map.file_name
+  in
+  (* Scope should be the fully qualified ocaml name as well as the mapped ocaml name *)
+  let scope =
+    let proto_path = Option.value ~default "" package in
+    let ocaml_path =
+      String.split_on_char ~sep:"." proto_path
+      |> List.map ~f:(Names.module_name ~mangle_f)
+      |> String.concat ~sep:"."
+    in
+    { proto_path; ocaml_path; module_name }
+  in
+  (* Start traversing *)
+  let traverse_
+
+
+
+  DescriptorProto.{ name; field = fields; nested_type = nested_types; enum_type = enums; oneof_decl = oneof_decls; extension = extensions; _} =
+  let name = Option.value_exn ~message:"All messages must have a name" name in

src/plugin/type_tree.ml

@@ -160,50 +160,6 @@ let create_cyclic_map { file_name = _; types; package = _ } =
   let map = List.fold_left ~init:StringMap.empty ~f:(traverse "") types in
   StringMap.mapi ~f:(fun name _ -> is_cyclic map name) map
 
-(** Create a map: proto_name -> ocaml_name.
-    Mapping is done in multiple passes to prioritize which mapping wins in case of name clashes
-*)
-let create_name_map ~standard_f ~mangle_f names =
-  let rec uniq_name names ocaml_name =
-    match List.assoc_opt ocaml_name names with
-    | None -> ocaml_name
-    | Some _ -> uniq_name names (ocaml_name ^ "'")
-  in
-  let names =
-    List.map ~f:(fun name ->
-      let mangle_name = mangle_f name in
-      let standard_name = standard_f name in
-      (name, mangle_name, standard_name)
-    ) names
-  in
-  let standard_name_map =
-    let inject ~f map =
-      List.fold_left ~init:map ~f:(fun map (name, mangled_name, standard_name) ->
-        match f name mangled_name standard_name with
-        | true when StringMap.mem mangled_name map -> map
-        | true -> StringMap.add ~key:mangled_name ~data:name map
-        | false -> map
-      ) names
-    in
-    StringMap.empty
-    |> inject ~f:(fun name mangled_name _standard_name -> String.equal mangled_name name)
-    |> inject ~f:(fun _name mangled_name standard_name -> String.equal mangled_name standard_name)
-    |> inject ~f:(fun name mangled_name _standard_name -> String.equal (String.lowercase_ascii mangled_name) (String.lowercase_ascii name))
-    |> inject ~f:(fun _name mangled_name standard_name -> String.equal (String.lowercase_ascii mangled_name) (String.lowercase_ascii standard_name))
-  in
-  List.fold_left ~init:[] ~f:(fun names (proto_name, ocaml_name, _) ->
-    let ocaml_name =
-      match StringMap.find_opt ocaml_name standard_name_map with
-      | Some name when String.equal name proto_name -> ocaml_name
-      | Some _ -> ocaml_name ^ "'"
-      | None -> ocaml_name
-    in
-    (uniq_name names ocaml_name, proto_name) :: names
-  ) names
-  |> List.fold_left ~init:StringMap.empty ~f:(fun map (ocaml_name, proto_name) ->
-    StringMap.add ~key:proto_name ~data:ocaml_name map
-  )
-
 (** Create a type db: map proto-type -> { module_name, ocaml_name, is_cyclic } *)
 let create_file_db ~module_name ~mangle cyclic_map types =
   let mangle_f = match mangle with
@@ -231,30 +187,30 @@ let create_file_db ~module_name ~mangle cyclic_map types =
       let path = path ^ "." ^ name in
       let cyclic = StringMap.find path cyclic_map in
       let map =
-        create_name_map
+        Names.create_name_map
           ~standard_f:(Names.field_name ~mangle_f:(fun x -> x))
           ~mangle_f:(Names.field_name ~mangle_f)
           plain_fields
         |> add_names ~path ~ocaml_name map
       in
       let map =
         List.fold_left ~init:map ~f:(fun map fields ->
-          create_name_map
+          Names.create_name_map
             ~standard_f:(Names.poly_constructor_name ~mangle_f:(fun x -> x))
             ~mangle_f:(Names.poly_constructor_name ~mangle_f)
             fields
           |> add_names ~path ~ocaml_name map
         ) oneof_fields
       in
       let map =
-        create_name_map
+        Names.create_name_map
           ~standard_f:(Names.module_name ~mangle_f:(fun x -> x))
           ~mangle_f:(Names.module_name ~mangle_f)
           enum_names
         |> add_names ~path ~ocaml_name map
       in
       let map =
-        create_name_map
+        Names.create_name_map
           ~standard_f:(Names.field_name ~mangle_f:(fun x -> x))
           ~mangle_f:(Names.field_name ~mangle_f)
           service_names
@@ -266,7 +222,7 @@ let create_file_db ~module_name ~mangle cyclic_map types =
     in
     let name_map =
       List.map ~f:(fun { name; _ } -> name) types
-      |> create_name_map
+      |> Names.create_name_map
            ~standard_f:(Names.module_name ~mangle_f:(fun x -> x))
            ~mangle_f:(Names.module_name ~mangle_f)
     in