Source file pb_codegen_decode_pb_options.ml

module Ot = Pb_codegen_ocaml_type
module F = Pb_codegen_formatting

let sp = Pb_codegen_util.sp

let field_pattern_match ~r_name ~rf_label field_type =
  match field_type with
  | Ot.Ft_basic_type bt ->
    let decode runtime_f =
      sp "Pbrt_options.%s pb_options_value \"%s\" \"%s\"" runtime_f r_name
        rf_label
    in
    let exp =
      match bt with
      | Ot.Bt_string -> decode "string"
      | Ot.Bt_float -> decode "float"
      | Ot.Bt_int -> decode "int"
      | Ot.Bt_int32 -> decode "int32"
      | Ot.Bt_int64 -> decode "int64"
      | Ot.Bt_uint32 -> sp "`unsigned (%s)" (decode "int32")
      | Ot.Bt_uint64 -> sp "`unsigned (%s)" (decode "int64")
      | Ot.Bt_bool -> decode "bool"
      | Ot.Bt_bytes -> decode "bytes"
    in
    "pb_options_value", exp
  | Ot.Ft_unit ->
    ( "pb_options_value",
      sp "Pbrt_options.unit pb_options_value \"%s\" \"%s\"" r_name rf_label )
  | Ot.Ft_user_defined_type udt ->
    let f_name =
      let function_prefix = "decode_pb_options" in
      Pb_codegen_util.function_name_of_user_defined ~function_prefix udt
    in
    let value_expression = "(" ^ f_name ^ " pb_options_value)" in
    "pb_options_value", value_expression
  | _ -> assert false

let pb_options_label_of_field_label rf_label =
  match rf_label with
  | "and_" | "as_" | "assert_" | "begin_" | "class_" | "constraint_" | "do_"
  | "done_" | "downto_" | "else_" | "end_" | "exception_" | "external_"
  | "false_" | "for_" | "fun_" | "function_" | "functor_" | "if_" | "in_"
  | "include_" | "inherit_" | "initializer_" | "lazy_" | "let_" | "match_"
  | "method_" | "module_" | "mutable_" | "new_" | "nonrec_" | "object_" | "of_"
  | "open_" | "or_" | "private_" | "rec_" | "sig_" | "struct_" | "then_" | "to_"
  | "true_" | "try_" | "type_" | "unit_" | "val_" | "virtual_" | "when_"
  | "while_" | "with_" | "mod_" | "land_" | "lor_" | "lxor_" | "lsl_" | "lsr_"
  | "asr_" ->
    String.sub rf_label 0 (String.length rf_label - 1)
  | _ -> rf_label

(* Generate all the pattern matches for a record field *)
let gen_rft_nolabel sc ~r_name ~rf_label (field_type, _, _) =
  let pb_options_label = pb_options_label_of_field_label rf_label in

  let match_variable_name, exp =
    field_pattern_match ~r_name ~rf_label field_type
  in
  F.linep sc "| (\"%s\", %s) -> " pb_options_label match_variable_name;
  F.linep sc "  %s_set_%s v (%s)" r_name rf_label exp

(* Generate all the pattern matches for a repeated field *)
let gen_rft_repeated_field sc ~r_name ~rf_label repeated_field =
  let _, field_type, _, _, _ = repeated_field in

  let pb_options_label = pb_options_label_of_field_label rf_label in

  F.linep sc "| (\"%s\", Pbrt_options.List_literal l) -> begin" pb_options_label;

  F.sub_scope sc (fun sc ->
      F.linep sc "%s_set_%s v @@ List.map (function" r_name rf_label;
      let match_variable_name, exp =
        field_pattern_match ~r_name ~rf_label field_type
      in
      F.linep sc "  | %s -> %s" match_variable_name exp;
      F.line sc ") l;");

  F.line sc "end"

let gen_rft_optional_field sc ~r_name ~rf_label optional_field =
  let field_type, _, _, _ = optional_field in

  let pb_options_label = pb_options_label_of_field_label rf_label in

  let match_variable_name, exp =
    field_pattern_match ~r_name ~rf_label field_type
  in

  F.linep sc "| (\"%s\", %s) -> " pb_options_label match_variable_name;
  F.linep sc "  %s_set_%s v (%s)" r_name rf_label exp

(* Generate pattern match for a variant field *)
let gen_rft_variant_field sc ~r_name ~rf_label { Ot.v_constructors; _ } =
  List.iter
    (fun { Ot.vc_constructor; vc_field_type; _ } ->
      let pb_options_label =
        Pb_codegen_util.camel_case_of_constructor vc_constructor
      in

      match vc_field_type with
      | Ot.Vct_nullary ->
        F.linep sc "| (\"%s\", _) -> %s_set_%s v (%s)" pb_options_label r_name
          rf_label vc_constructor
      | Ot.Vct_non_nullary_constructor field_type ->
        let match_variable_name, exp =
          field_pattern_match ~r_name ~rf_label field_type
        in
        F.linep sc "| (\"%s\", %s) -> " pb_options_label match_variable_name;
        F.linep sc "  %s_set_%s v (%s (%s))" r_name rf_label vc_constructor exp)
    v_constructors

let gen_rft_assoc_field sc ~r_name ~rf_label ~assoc_type ~key_type ~value_type =
  let pb_options_label = pb_options_label_of_field_label rf_label in
  F.linep sc "| (\"%s\", Pbrt_options.Message_literal assoc) ->"
    pb_options_label;
  F.sub_scope sc (fun sc ->
      let value_name, value_exp =
        field_pattern_match ~r_name ~rf_label value_type
      in
      let key_name = "key" in
      let key_exp =
        match key_type with
        | Ot.Bt_string -> "key"
        | Ot.Bt_int -> "(Int.of_string key)"
        | Ot.Bt_int32 -> "(Int32.of_string key)"
        | Ot.Bt_int64 -> "(Int64.of_string key)"
        | Ot.Bt_uint32 -> "(`unsigned (Int32.of_string key))"
        | Ot.Bt_uint64 -> "(`unsigned (Int64.of_string key))"
        | Ot.Bt_bool -> "(Bool.of_string key)"
        | Ot.Bt_float ->
          Printf.eprintf "float cannot be used as a map key type";
          exit 1
        | Ot.Bt_bytes ->
          Printf.eprintf "bytes cannot be used as a map key type";
          exit 1
      in
      F.line sc "let assoc =";
      F.sub_scope sc (fun sc ->
          F.line sc "assoc";
          F.linep sc "|> List.map (fun (%s, %s) -> (%s, %s)) " key_name
            value_name key_exp value_exp;
          F.line sc "|> List.to_seq";
          (* Passing through [Hashtbl.of_seq] even in the [At_list] case ensures that if there
             is a repeated key we take the last value associated with it. *)
          F.line sc "|> Hashtbl.of_seq");
      F.line sc "in";
      let assoc_exp =
        match assoc_type with
        | Ot.At_hashtable -> "assoc"
        | Ot.At_list -> "assoc |> Hashtbl.to_seq |> List.of_seq"
      in
      F.linep sc "%s_set_%s v (%s)" r_name rf_label assoc_exp)

(* Generate decode function for a record *)
let gen_record ?and_ { Ot.r_name; r_fields } sc =
  F.line sc
  @@ sp "%s decode_pb_options_%s d ="
       (Pb_codegen_util.let_decl_of_and and_)
       r_name;

  F.sub_scope sc (fun sc ->
      F.linep sc "let v = default_%s () in" r_name;
      F.line sc @@ "let assoc = match d with";
      F.line sc @@ "  | Pbrt_options.Message_literal assoc -> assoc";
      F.line sc @@ "  | _ -> assert(false)";
      (* TODO raise E *)
      F.line sc @@ "in";

      F.line sc "List.iter (function ";
      F.sub_scope sc (fun sc ->
          (* Generate pattern match for all the possible message field *)
          List.iter
            (fun { Ot.rf_label; rf_field_type; _ } ->
              match rf_field_type with
              | Ot.Rft_nolabel nolabel_field ->
                gen_rft_nolabel sc ~r_name ~rf_label nolabel_field
              | Ot.Rft_repeated repeated_field ->
                gen_rft_repeated_field sc ~r_name ~rf_label repeated_field
              | Ot.Rft_variant variant_field ->
                gen_rft_variant_field sc ~r_name ~rf_label variant_field
              | Ot.Rft_optional optional_field ->
                gen_rft_optional_field sc ~r_name ~rf_label optional_field
              | Ot.Rft_required _ ->
                Printf.eprintf
                  "Only proto3 syntax supported in pb_options encoding";
                exit 1
              | Ot.Rft_associative
                  (assoc_type, _, (key_type, _), (value_type, _)) ->
                gen_rft_assoc_field sc ~r_name ~rf_label ~assoc_type ~key_type
                  ~value_type)
            r_fields;

          (* Unknown fields are simply ignored *)
          F.empty_line sc;
          F.line sc "| (_, _) -> () (*Unknown fields are ignored*)");
      F.line sc ") assoc;";
      F.linep sc "(v : %s)" r_name)

(* Generate decode function for an empty record *)
let gen_unit ?and_ { Ot.er_name } sc =
  F.line sc
  @@ sp "%s decode_pb_options_%s d ="
       (Pb_codegen_util.let_decl_of_and and_)
       er_name;
  F.line sc (sp "Pbrt_options.unit d \"%s\" \"%s\"" er_name "empty record")

(* Generate decode function for a variant type *)
let gen_variant ?and_ { Ot.v_name; v_constructors; v_use_polyvariant = _ } sc =
  (* helper function for each constructor case *)
  let process_v_constructor sc { Ot.vc_constructor; vc_field_type; _ } =
    let pb_options_label =
      Pb_codegen_util.camel_case_of_constructor vc_constructor
    in

    match vc_field_type with
    | Ot.Vct_nullary ->
      F.linep sc "| (\"%s\", _)::_-> (%s : %s)" pb_options_label vc_constructor
        v_name
    | Ot.Vct_non_nullary_constructor field_type ->
      let match_, exp =
        let r_name = v_name and rf_label = vc_constructor in
        field_pattern_match ~r_name ~rf_label field_type
      in

      F.linep sc "| (\"%s\", %s)::_ -> " pb_options_label match_;
      F.linep sc "  (%s (%s) : %s)" vc_constructor exp v_name
  in

  F.linep sc "%s decode_pb_options_%s pb_options ="
    (Pb_codegen_util.let_decl_of_and and_)
    v_name;

  F.sub_scope sc (fun sc ->
      (* even though a variant should be an object with a single field,
       * it is possible other fields are present in the pb_options object. Therefore
       * we still need a loop to iterate over the key/value, even if in 99.99%
       * of the cases it will be a single iteration *)
      F.line sc "let assoc = match pb_options with";
      F.line sc "  | Pbrt_options.Message_literal assoc -> assoc";
      F.line sc "  | _ -> assert(false)";
      (* TODO raise E *)
      F.line sc "in";

      F.line sc "let rec loop = function";
      F.sub_scope sc (fun sc ->
          (* termination condition *)
          F.linep sc "| [] -> Pbrt_options.E.malformed_variant \"%s\"" v_name;

          List.iter (process_v_constructor sc) v_constructors;

          F.empty_line sc;
          F.line sc "| _ :: tl -> loop tl");
      F.line sc "in";
      F.line sc "loop assoc")

let gen_const_variant ?and_ { Ot.cv_name; cv_constructors } sc =
  F.linep sc "%s decode_pb_options_%s pb_options ="
    (Pb_codegen_util.let_decl_of_and and_)
    cv_name;

  F.sub_scope sc (fun sc ->
      F.line sc "match pb_options with";
      List.iter
        (fun { Ot.cvc_name; cvc_string_value; _ } ->
          F.linep sc
            "| Pbrt_options.Scalar_value (Constant_literal \"%s\") -> (%s : %s)"
            cvc_string_value cvc_name cv_name)
        cv_constructors;
      F.linep sc "| _ -> Pbrt_options.E.malformed_variant \"%s\"" cv_name)

let gen_struct ?and_ ~mode t sc =
  Pb_codegen_mode.do_decode mode
  &&
  let { Ot.spec; _ } = t in
  let has_encoded =
    match spec with
    | Ot.Record r ->
      gen_record ?and_ r sc;
      true
    | Ot.Variant v ->
      gen_variant ?and_ v sc;
      true
    | Ot.Const_variant v ->
      gen_const_variant ?and_ v sc;
      true
    | Ot.Unit u ->
      gen_unit ?and_ u sc;
      true
  in
  has_encoded

let gen_sig ?and_ ~mode t sc =
  Pb_codegen_mode.do_decode mode
  &&
  let _ = and_ in
  let { Ot.spec; _ } = t in

  let f type_name =
    F.linep sc "val decode_pb_options_%s : Pbrt_options.value -> %s" type_name
      type_name;
    F.linep sc
      ("(** [decode_pb_options_%s decoder] decodes a "
     ^^ "[%s] value from [decoder] *)")
      type_name type_name
  in

  match spec with
  | Ot.Record { Ot.r_name; _ } ->
    f r_name;
    true
  | Ot.Variant { Ot.v_name; _ } ->
    f v_name;
    true
  | Ot.Const_variant { Ot.cv_name; _ } ->
    f cv_name;
    true
  | Ot.Unit { Ot.er_name; _ } ->
    f er_name;
    true

let ocamldoc_title = "Pb_option.set Decoding"

let plugin : Pb_codegen_plugin.t =
  let module P = struct
    let gen_sig = gen_sig
    let gen_struct = gen_struct
    let ocamldoc_title = ocamldoc_title
  end in
  (module P)