Source file pb_codegen_pp.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
module Ot = Pb_codegen_ocaml_type
module F = Pb_codegen_formatting
module L = Pb_logger
open Pb_codegen_util

let gen_field field_type =
  match field_type with
  | Ot.Ft_user_defined_type udt ->
    let function_prefix = "pp" in
    function_name_of_user_defined ~function_prefix udt
  | Ot.Ft_wrapper_type { Ot.wt_type; _ } ->
    sp "Pbrt.Pp.pp_wrapper_%s" (string_of_basic_type ~for_pp:true wt_type)
  | _ -> sp "Pbrt.Pp.pp_%s" (string_of_field_type ~for_pp:true field_type)

let gen_record ?and_ { Ot.r_name; r_fields } sc =
  L.log "gen_pp, record_name: %s\n" r_name;

  F.line sc @@ sp "%s pp_%s fmt (v:%s) = " (let_decl_of_and and_) r_name r_name;
  F.sub_scope sc (fun sc ->
      F.line sc "let pp_i fmt () =";
      F.sub_scope sc (fun sc ->
          List.iteri
            (fun i record_field ->
              let first = i = 0 in
              let { Ot.rf_label; rf_field_type; _ } = record_field in

              let var_name = sp "v.%s" rf_label in
              match rf_field_type with
              | Ot.Rft_nolabel (field_type, _, _)
              | Ot.Rft_required (field_type, _, _, _) ->
                let field_string_of = gen_field field_type in
                F.line sc
                @@ sp "Pbrt.Pp.pp_record_field ~first:%b \"%s\" %s fmt %s;"
                     first rf_label field_string_of var_name
                (* Rft_required *)
              | Ot.Rft_optional (field_type, _, _, _) ->
                let field_string_of = gen_field field_type in
                F.line sc
                @@ sp
                     "Pbrt.Pp.pp_record_field ~first:%b \"%s\" \
                      (Pbrt.Pp.pp_option %s) fmt %s;"
                     first rf_label field_string_of var_name
                (* Rft_optional *)
              | Ot.Rft_repeated (rt, field_type, _, _, _) ->
                let field_string_of = gen_field field_type in
                (match rt with
                | Ot.Rt_list ->
                  F.line sc
                  @@ sp
                       "Pbrt.Pp.pp_record_field ~first:%b \"%s\" \
                        (Pbrt.Pp.pp_list %s) fmt %s;"
                       first rf_label field_string_of var_name
                | Ot.Rt_repeated_field ->
                  F.line sc
                  @@ sp
                       "Pbrt.Pp.pp_record_field ~first:%b \"%s\" \
                        (Pbrt.Pp.pp_list %s) fmt (Pbrt.Repeated_field.to_list \
                        %s);"
                       first rf_label field_string_of var_name)
                (* Rft_repeated_field *)
              | Ot.Rft_variant { Ot.v_name; v_constructors = _ } ->
                (* constructors are ignored because the pretty printing is completely
                 * delegated to the pretty print function associated with that variant.
                 * This is indeed different from the [decode]/[encode] functions which
                 * requires `inlining` the decoding/encoding logic within the record (This
                 * requirement is indeed comming from the imposed Protobuf format)
                 *)
                F.line sc
                @@ sp "Pbrt.Pp.pp_record_field ~first:%b \"%s\" %s fmt %s;"
                     first rf_label ("pp_" ^ v_name) var_name
                (* Rft_variant_field *)
              | Ot.Rft_associative (at, _, (key_type, _), (value_type, _)) ->
                let pp_runtime_function =
                  match at with
                  | Ot.At_list -> "pp_associative_list"
                  | Ot.At_hashtable -> "pp_hastable"
                in
                let pp_key = gen_field (Ot.Ft_basic_type key_type) in
                let pp_value = gen_field value_type in
                F.line sc
                @@ sp
                     "Pbrt.Pp.pp_record_field ~first:%b \"%s\" (Pbrt.Pp.%s %s \
                      %s) fmt %s;"
                     first rf_label pp_runtime_function pp_key pp_value var_name
              (* Associative_list *))
            r_fields);
      F.line sc "in";
      F.line sc "Pbrt.Pp.pp_brk pp_i fmt ()")

let gen_unit ?and_ { Ot.er_name } sc : unit =
  F.line sc
  @@ sp "%s pp_%s fmt (v:%s) = " (let_decl_of_and and_) er_name er_name;
  F.sub_scope sc (fun sc ->
      F.line sc "let pp_i fmt () =";
      F.sub_scope sc (fun sc -> F.line sc "Pbrt.Pp.pp_unit fmt ()");
      F.line sc "in";
      F.line sc "Pbrt.Pp.pp_brk pp_i fmt ()")

let gen_variant ?and_ { Ot.v_name; Ot.v_constructors } sc =
  F.line sc @@ sp "%s pp_%s fmt (v:%s) =" (let_decl_of_and and_) v_name v_name;
  F.sub_scope sc (fun sc ->
      F.line sc "match v with";
      List.iter
        (fun { Ot.vc_constructor; vc_field_type; _ } ->
          match vc_field_type with
          | Ot.Vct_nullary ->
            F.line sc
            @@ sp "| %s  -> Format.fprintf fmt \"%s\"" vc_constructor
                 vc_constructor
          | Ot.Vct_non_nullary_constructor field_type ->
            let field_string_of = gen_field field_type in
            F.line sc
            @@ sp "| %s x -> Format.fprintf fmt \"@[<hv2>%s(@,%%a)@]\" %s x"
                 vc_constructor vc_constructor field_string_of)
        v_constructors)

let gen_const_variant ?and_ { Ot.cv_name; cv_constructors } sc =
  F.line sc @@ sp "%s pp_%s fmt (v:%s) =" (let_decl_of_and and_) cv_name cv_name;
  F.sub_scope sc (fun sc ->
      F.line sc "match v with";
      List.iter
        (fun { Ot.cvc_name; _ } ->
          F.line sc @@ sp "| %s -> Format.fprintf fmt \"%s\"" cvc_name cvc_name)
        cv_constructors)

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

let gen_sig ?and_ t sc =
  let _ = and_ in
  let { Ot.spec; _ } = t in
  let f type_name =
    F.line sc
    @@ sp "val pp_%s : Format.formatter -> %s -> unit " type_name type_name;
    F.line sc @@ sp "(** [pp_%s v] formats v *)" type_name
  in
  (match spec with
  | Ot.Record { Ot.r_name; _ } -> f r_name
  | Ot.Variant v -> f v.Ot.v_name
  | Ot.Const_variant { Ot.cv_name; _ } -> f cv_name
  | Ot.Unit { Ot.er_name; _ } -> f er_name);
  true

let ocamldoc_title = "Formatters"
let requires_mutable_records = false

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
    let requires_mutable_records = requires_mutable_records
  end in
  (module P)