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
module Ot = Pb_codegen_ocaml_type
module F = Pb_codegen_formatting
module L = Pb_logger

let file_suffix = "pp"

open Pb_codegen_util

let gen_field field_type =
  match field_type with
  | Ot.Ft_user_defined_type udt ->
    let function_prefix = "pp" in
    let module_suffix = file_suffix in
    function_name_of_user_defined ~function_prefix ~module_suffix 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_ module_prefix { 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_types.%s) = " (let_decl_of_and and_) r_name
       module_prefix r_name;
  F.scope sc (fun sc ->
      F.line sc "let pp_i fmt () =";
      F.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_types.%s" module_prefix 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_variant ?and_ module_prefix { Ot.v_name; Ot.v_constructors } sc =
  F.line sc
  @@ sp "%s pp_%s fmt (v:%s_types.%s) =" (let_decl_of_and and_) v_name
       module_prefix v_name;
  F.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_types.%s  -> Format.fprintf fmt \"%s\"" module_prefix
                 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_types.%s x -> Format.fprintf fmt \"@[<hv2>%s(@,\
                  %%a)@]\" %s x" module_prefix vc_constructor vc_constructor
                 field_string_of)
        v_constructors)

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

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

let gen_sig ?and_ t sc =
  let _ = and_ in
  let { Ot.module_prefix; spec; _ } = t in
  let f type_name =
    F.line sc
    @@ sp "val pp_%s : Format.formatter -> %s_types.%s -> unit " type_name
         module_prefix 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);
  true

let ocamldoc_title = "Formatters"