Merge pull request mransan#242 from Lupus/more-compliant-options-parsing

More compliant options parsing

src/compilerlib/dune

@@ -14,8 +14,8 @@
    pb_codegen_encode_yojson pb_codegen_formatting pb_codegen_ocaml_type_dump
    pb_codegen_ocaml_type pb_codegen_pp pb_codegen_plugin pb_codegen_types
    pb_codegen_services pb_codegen_util pb_exception pb_field_type pb_location
-   pb_logger pb_option pb_parsing pb_parsing_lexer pb_parsing_parser
-   pb_parsing_parse_tree pb_parsing_util pb_typing_graph pb_typing
-   pb_typing_recursion pb_typing_resolution pb_typing_type_tree
+   pb_logger pb_option pb_raw_option pb_parsing pb_parsing_lexer
+   pb_parsing_parser pb_parsing_parse_tree pb_parsing_util pb_typing_graph
+   pb_typing pb_typing_recursion pb_typing_resolution pb_typing_type_tree
    pb_typing_util pb_typing_validation pb_util pb_format_util)
  (libraries stdlib-shims))

src/compilerlib/pb_codegen_all.ml

@@ -40,7 +40,7 @@ let new_ocaml_mod ~proto_file_options ~proto_file_name () : ocaml_mod =
   let self = { ml = F.empty_scope (); mli = F.empty_scope () } in
 
   let print_ppx sc =
-    match Pb_option.get proto_file_options "ocaml_file_ppx" with
+    match Pb_raw_option.get_ext proto_file_options "ocaml_file_ppx" with
     | None -> ()
     | Some Pb_option.(Scalar_value (Constant_string s)) ->
       F.linep sc "[@@@%s]" s

src/compilerlib/pb_codegen_all.mli

@@ -12,7 +12,7 @@ type ocaml_mod = {
 val codegen :
   Ot.proto ->
   generate_make:bool ->
-  proto_file_options:Pb_option.set ->
+  proto_file_options:Pb_raw_option.set ->
   proto_file_name:string ->
   services:bool ->
   Plugin.t list ->

src/compilerlib/pb_codegen_backend.ml

@@ -195,7 +195,7 @@ let encoding_info_of_field_type ~all_types field_type : Ot.payload_kind =
 let encoding_of_field ~all_types (field : (Pb_field_type.resolved, 'a) Tt.field)
     =
   let packed =
-    match Typing_util.field_option field "packed" with
+    match Typing_util.field_option field (Pb_option.Simple_name "packed") with
     | Some Pb_option.(Scalar_value (Constant_bool x)) -> x
     | Some _ -> E.invalid_packed_option (Typing_util.field_name field)
     | None -> false
@@ -209,34 +209,34 @@ let encoding_of_field ~all_types (field : (Pb_field_type.resolved, 'a) Tt.field)
 let compile_field_type ~unsigned_tag ~(all_types : _ Tt.proto_type list)
     file_options field_options file_name field_type : Ot.field_type =
   let ocaml_type =
-    match Pb_option.get field_options "ocaml_type" with
+    match Pb_option.get_ext field_options "ocaml_type" with
     | Some Pb_option.(Scalar_value (Constant_literal "int_t")) -> `Int_t
     | _ -> `None
   in
 
   let int32_type =
-    match Pb_option.get file_options "int32_type" with
+    match Pb_option.get_ext file_options "int32_type" with
     | Some Pb_option.(Scalar_value (Pb_option.Constant_literal "int_t")) ->
       Ot.(Ft_basic_type Bt_int)
     | _ -> Ot.(Ft_basic_type Bt_int32)
   in
 
   let uint32_type =
-    match Pb_option.get file_options "int32_type" with
+    match Pb_option.get_ext file_options "int32_type" with
     | Some Pb_option.(Scalar_value (Constant_literal "int_t")) ->
       Ot.(Ft_basic_type Bt_int)
     | _ -> Ot.(Ft_basic_type Bt_uint32)
   in
 
   let int64_type =
-    match Pb_option.get file_options "int64_type" with
+    match Pb_option.get_ext file_options "int64_type" with
     | Some Pb_option.(Scalar_value (Constant_literal "int_t")) ->
       Ot.(Ft_basic_type Bt_int)
     | _ -> Ot.(Ft_basic_type Bt_int64)
   in
 
   let uint64_type =
-    match Pb_option.get file_options "int64_type" with
+    match Pb_option.get_ext file_options "int64_type" with
     | Some Pb_option.(Scalar_value (Constant_literal "int_t")) ->
       Ot.(Ft_basic_type Bt_int)
     | _ -> Ot.(Ft_basic_type Bt_uint64)
@@ -289,13 +289,13 @@ let compile_field_type ~unsigned_tag ~(all_types : _ Tt.proto_type list)
   | `User_defined id, _ -> user_defined_type_of_id ~all_types ~file_name id
 
 let is_mutable ?field_name field_options =
-  match Pb_option.get field_options "ocaml_mutable" with
+  match Pb_option.get_ext field_options "ocaml_mutable" with
   | Some Pb_option.(Scalar_value (Constant_bool v)) -> v
   | Some _ -> Pb_exception.invalid_mutable_option ?field_name ()
   | None -> false
 
 let ocaml_container field_options =
-  match Pb_option.get field_options "ocaml_container" with
+  match Pb_option.get_ext field_options "ocaml_container" with
   | None -> None
   | Some Pb_option.(Scalar_value (Constant_literal container_name)) ->
     Some container_name
@@ -371,7 +371,7 @@ let process_all_types_ppx_extension file_name file_options
   match type_level_ppx_extension with
   | Some x -> Some x
   | None ->
-    Pb_option.get file_options "ocaml_all_types_ppx"
+    Pb_option.get_ext file_options "ocaml_all_types_ppx"
     |> string_of_string_option file_name
 
 let compile_message ~(unsigned_tag : bool) (file_options : Pb_option.set)
@@ -388,7 +388,8 @@ let compile_message ~(unsigned_tag : bool) (file_options : Pb_option.set)
   let { Tt.message_names; _ } = scope in
 
   let type_level_ppx_extension =
-    Typing_util.message_option message "ocaml_type_ppx"
+    Typing_util.message_option message
+      (Pb_option.Extension_name "ocaml_type_ppx")
     |> string_of_string_option message_name
     |> process_all_types_ppx_extension file_name file_options
   in
@@ -633,7 +634,7 @@ let compile_enum file_options file_name scope enum =
   in
 
   let type_level_ppx_extension =
-    Typing_util.enum_option enum "ocaml_enum_ppx"
+    Typing_util.enum_option enum (Pb_option.Extension_name "ocaml_enum_ppx")
     |> string_of_string_option enum_name
     |> process_all_types_ppx_extension file_name file_options
   in

src/compilerlib/pb_codegen_ocaml_type_dump.ml

@@ -74,29 +74,6 @@ module PP = struct
     | Constant_literal s ->
       Printf.sprintf "Constant_literal %S" (String.escaped s)
 
-  (* Helper function to convert value to string *)
-  let rec string_of_value value =
-    match value with
-    | Pb_option.Scalar_value c -> string_of_constant c
-    | Message_literal ml -> string_of_message_literal ml
-    | List_literal ll -> string_of_list_literal ll
-
-  (* Helper function to convert message_literal to string *)
-  and string_of_message_literal ml =
-    "{"
-    ^ String.concat ", "
-        (List.map
-           (fun (k, v) -> Printf.sprintf "%S: %s" k (string_of_value v))
-           ml)
-    ^ "}"
-
-  (* Helper function to convert list_literal to string *)
-  and string_of_list_literal ll =
-    "[" ^ String.concat ", " (List.map string_of_value ll) ^ "]"
-
-  (* Function to convert options (message_literal) to string *)
-  let string_of_options options = string_of_message_literal options
-
   (* Helper function to convert default_value to string *)
   let string_of_default_value dv =
     match dv with
@@ -171,7 +148,8 @@ module PP = struct
       (string_of_variant_constructor_type vc.vc_field_type);
     F.linep sc "    Encoding Number: %d, Payload Kind: %s" vc.vc_encoding_number
       (string_of_payload_kind vc.vc_payload_kind);
-    F.linep sc "    Options: %s" (string_of_options vc.vc_options)
+    F.linep sc "    Options: %s"
+      (Format.asprintf "%a" Pb_option.pp_set vc.vc_options)
 
   (* Helper function to convert variant_constructor_type to string *)
   and string_of_variant_constructor_type vct =
@@ -189,7 +167,8 @@ module PP = struct
   and print_record_field sc record_field =
     F.linep sc "- Field: %s" record_field.rf_label;
     print_record_field_type sc record_field.rf_field_type;
-    F.linep sc "  Field options: %s" (string_of_options record_field.rf_options)
+    F.linep sc "  Field options: %s"
+      (Format.asprintf "%a" Pb_option.pp_set record_field.rf_options)
 
   (* Recursive function to print a const_variant *)
   let rec print_const_variant sc const_variant =
@@ -201,7 +180,8 @@ module PP = struct
     F.linep sc "  Constructor: %s" cvc.cvc_name;
     F.linep sc "    Binary Value: %d, String Value: %s" cvc.cvc_binary_value
       cvc.cvc_string_value;
-    F.linep sc "    Options: %s" (string_of_options cvc.cvc_options)
+    F.linep sc "    Options: %s"
+      (Format.asprintf "%a" Pb_option.pp_set cvc.cvc_options)
 
   (* Recursive function to print the type_spec *)
   let print_type_spec sc type_spec =
@@ -215,7 +195,8 @@ module PP = struct
   let print_type sc type_ =
     F.linep sc "Module Prefix: %s" type_.module_prefix;
     print_type_spec sc type_.spec;
-    F.linep sc "Options: %s" (string_of_options type_.type_options);
+    F.linep sc "Options: %s"
+      (Format.asprintf "%a" Pb_option.pp_set type_.type_options);
     match type_.type_level_ppx_extension with
     | Some ext -> F.linep sc "PPX Extension: %s" ext
     | None -> ()

src/compilerlib/pb_option.ml

@@ -1,10 +1,39 @@
+(*
+  The MIT License (MIT)
+
+  Copyright (c) 2016 Maxime Ransan <maxime.ransan@gmail.com>
+
+  Permission is hereby granted, free of charge, to any person obtaining a copy
+  of this software and associated documentation files (the "Software"), to deal
+  in the Software without restriction, including without limitation the rights
+  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+  copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in all
+  copies or substantial portions of the Software.
+
+  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+  IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+  AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+  OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+  SOFTWARE.
+
+*)
+
 type constant =
   | Constant_string of string
   | Constant_bool of bool
   | Constant_int of int
   | Constant_float of float
   | Constant_literal of string
 
+type option_name =
+  | Simple_name of string
+  | Extension_name of string
+
 type message_literal = (string * value) list
 and list_literal = value list
 
@@ -13,19 +42,92 @@ and value =
   | Message_literal of message_literal
   | List_literal of list_literal
 
-type option_name = string
 type t = option_name * value
 type set = t list
 
+let stringify_option_name = function
+  | Simple_name s -> s
+  | Extension_name s -> "(" ^ s ^ ")"
+
+let option_name_equal a b =
+  match a, b with
+  | Simple_name a, Simple_name b -> String.equal a b
+  | Extension_name a, Extension_name b -> String.equal a b
+  | _ -> false
+
 let empty = []
-let add t option_name value = (option_name, value) :: t
-let merge t1 t2 = t2 @ t1
+
+let rec merge_value v1 v2 =
+  match v1, v2 with
+  | Message_literal ml1, Message_literal ml2 ->
+    (* In this case, both the existing and new values are messages.
+       Iterate through the fields of the new value.
+       For each field, check if a field with the same name exists in the existing value.
+       If it does and both field values are messages, merge them recursively.
+       If it does not, add the new field to the existing message. *)
+    let rec merge_lists list1 list2 =
+      match list2 with
+      | [] -> list1
+      | (field, value) :: rest ->
+        let updated_list, is_merged =
+          List.fold_left
+            (fun (acc, merged) (f, v) ->
+              if String.equal f field then (
+                match value, v with
+                | Message_literal _, Message_literal _ ->
+                  ( acc @ [ f, merge_value value v ],
+                    true (* recursively merges two message literals *) )
+                | _ -> acc @ [ f, value ], merged
+              ) else
+                acc @ [ f, v ], merged)
+            ([], false) list1
+        in
+        if is_merged then
+          (* If the current field of list2 was found in list1 and the two
+             values merged, continue with the rest of list2. The current field of
+             list2 is not added to updated_list as its value has already been
+             included during the merge. *)
+          merge_lists updated_list rest
+        else
+          (* If the current field of list2 was not found in list1, add it to
+             updated_list. *)
+          merge_lists (updated_list @ [ field, value ]) rest
+    in
+    Message_literal (merge_lists ml1 ml2)
+  | _ ->
+    (* FIXME: This overrides the scalar value of an existing option with the
+       scalar value of a new option, which is not allowed as per Protocol Buffer
+       Language Specification. *)
+    v2
+
+let add option_set option_name value =
+  match
+    List.partition
+      (fun ((name, _) : t) -> option_name_equal name option_name)
+      option_set
+  with
+  | [], _ ->
+    (* If the option does not currently exist in the set, add it *)
+    (option_name, value) :: option_set
+  | [ (_, existing_value) ], remainder ->
+    (* If the option already exists in the set, merge it's value with the new value *)
+    let merged_value = merge_value existing_value value in
+    (option_name, merged_value) :: remainder
+  | _ ->
+    (* This is a sanity check. As we use an equality function, List.partition should
+     * always partition the list into two lists where the first list has at most one element. 
+     * Hence, the condition that results in a call to failwith should never be satisfied. *)
+    failwith
+      "This should not happen, partition should result in at most single item \
+       in left component"
 
 let get t option_name =
-  match List.assoc option_name t with
-  | c -> Some c
+  match List.find (fun (other, _) -> option_name_equal option_name other) t with
+  | _, c -> Some c
   | exception Not_found -> None
 
+let get_ext t option_name = get t (Extension_name option_name)
+
 let pp_constant ppf = function
   | Constant_string s -> Format.fprintf ppf "%S" s
   | Constant_bool b -> Format.fprintf ppf "%B" b
@@ -56,7 +158,9 @@ and pp_message_field ppf (field, value) =
   Format.fprintf ppf "%S: %a" field pp_value value
 
 let pp_t ppf (name, value) =
-  Format.fprintf ppf "{@;<1 2>%S: %a@;<1 2>}" name pp_value value
+  Format.fprintf ppf "{@;<1 2>%S: %a@;<1 2>}"
+    (stringify_option_name name)
+    pp_value value
 
 let pp_set ppf set =
   Format.fprintf ppf "[@[<v>%a@]]"