Source file ppx_deriving_encoding.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
open Ppxlib
open Ast_builder.Default
open Ppx_deriving_encoding_lib
open Utils

module type S = S

let str_gen ~loc ~path:_ (rec_flag, l)
    enum ign mu force_debug rm_prefix option title description schema name modu
    camel snake wrap =
  if fake then []
  else (
    Utils.wrap modu;
    List.iter (fun t ->
        if List.length l >= 2 && List.length t.ptype_params = 0 then
          Encoding.unit_rec_encoding := Encoding.(SSet.add t.ptype_name.txt !unit_rec_encoding)) l;
    let l = List.map (fun t ->
        let enc = Encoding.expressions ~enum ~ign ~mu ~camel ~snake ?rm_prefix
            ?option ?title ?description ?schema ~wrap t in
        let enc_name = match name with
          | None -> enc_name ~search:false t.ptype_name.txt
          | Some n -> add_enc_name t.ptype_name.txt n; n in
        let params = List.map fst t.ptype_params in
        let expr = add_params_fun enc params in
        let typ =
          ptyp_constr ~loc (llid ~loc @@ enc_mod "encoding") [
            ptyp_constr ~loc (llid ~loc t.ptype_name.txt) params ] in
        let typ = add_params_fun_sig typ params in
        let expr, typ =
          if List.length l >= 2 && List.length params = 0 then
            pexp_fun (punit ~loc) expr,
            ptyp_arrow ~loc Nolabel (ptyp_constr ~loc (llid ~loc "unit") []) typ
          else expr, typ in
        value_binding ~loc ~pat:(ppat_constraint ~loc (pvar ~loc enc_name) typ)
          ~expr) l in
    let rec_flag = if List.length l < 2 then Nonrecursive else rec_flag in
    let s = [ pstr_value ~loc rec_flag l ] in
    debug ~force:force_debug "%s\n" (str_of_structure s);
    unwrap ();
    s)

let sig_gen ~loc ~path:_ (_rec_flag, l) name modu =
  if fake then []
  else (
    wrap modu;
    let l = List.map (fun t ->
        let name = match name with None -> enc_name ~search:false t.ptype_name.txt | Some n -> n in
        let params = List.map fst t.ptype_params in
        let typ = add_params_fun_sig
            (ptyp_constr ~loc (llid ~loc @@ enc_mod "encoding") [
                ptyp_constr ~loc (llid ~loc t.ptype_name.txt) params ]) params in
        value_description ~loc ~name:{txt=name; loc} ~type_:typ ~prim:[]) l in
    let s = List.map (psig_value ~loc) l in
    debug "%s\n" (str_of_signature s);
    unwrap ();
    s)

let eprefix t =
  let f = Deriving.Args.to_func t in
  Deriving.Args.of_func (fun ctx loc x k ->
      match rm_prefix_of_expr x with
      | None -> raise_error ~loc "wrong boolean argument"
      | Some x -> f ctx loc x k)

let () =
  let args_str = Deriving.Args.(
      empty
      +> flag "enum"
      +> flag "ignore"
      +> flag "recursive"
      +> flag "debug"
      +> arg "remove_prefix" (eprefix __)
      +> arg "option" (estring __)
      +> arg "title"  __
      +> arg "description" __
      +> arg "schema" __
      +> arg "name" (estring __)
      +> arg "module_name" (estring __)
      +> flag "camel"
      +> flag "snake"
      +> flag "wrap"
    ) in
  let args_sig = Deriving.Args.(
      empty
      +> arg "name" (estring __)
      +> arg "module_name" (estring __)
    ) in
  let str_type_decl = Deriving.Generator.make args_str str_gen in
  let sig_type_decl = Deriving.Generator.make args_sig sig_gen in
  Deriving.ignore @@ Deriving.add "encoding" ~str_type_decl ~sig_type_decl;
  Deriving.ignore @@ Deriving.add "json_encoding" ~str_type_decl ~sig_type_decl;