Source file ppx_derive_validate.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
open Ppxlib
open Ast_helper
open Validators
open Utils

let map_type_declaration ~loc td =
  match td.ptype_kind with
  | Ptype_record label_declarations ->
      let field_validators =
        label_declarations |> List.map field_validator_exp
      in

      (* field_validators *)
      (* |> List.map Pprintast.string_of_expression *)
      (* |> List.iter (Printf.printf "%s\n"); *)
      let body =
        Exp.(
          apply
            (ident
               { txt = Ldot (Lident "Validate", "record"); loc = td.ptype_loc })
            [ (Nolabel, expr_list td.ptype_loc field_validators) ])
      in

      let body =
        Exp.(
          apply
            (ident
               {
                 txt = Ldot (Lident "Validate", "validate");
                 loc = td.ptype_loc;
               })
            [ (Nolabel, body) ])
      in

      let record_name = td.ptype_name.txt in
      let function_name = "validate_" ^ record_name in

      let pattern = Pat.var { txt = function_name; loc } in
      let value_binding = Vb.mk pattern body in

      let function_item = Str.value Nonrecursive [ value_binding ] in
      function_item
  | _ -> Location.raise_errorf ~loc "Unsupported type"

let map_sig ~loc td =
  match td.ptype_kind with
  | Ptype_record _ ->
      let record_name = td.ptype_name.txt in
      let function_name = "validate_" ^ record_name in
      let function_name_loc = { txt = function_name; loc } in

      let input_type = Typ.constr { txt = Lident record_name; loc } [] in
      let output_type =
        Typ.constr
          { txt = Ldot (Lident "Validate", "validation_error"); loc }
          []
      in
      let result_type =
        Typ.constr { txt = Lident "result"; loc } [ input_type; output_type ]
      in
      let function_type = Typ.arrow Nolabel input_type result_type in
      Sig.value (Val.mk function_name_loc function_type)
  | _ -> Location.raise_errorf ~loc "Unsupported type"

let generate_impl ~ctxt (_rec_flag, type_declarations) =
  let loc = Expansion_context.Deriver.derived_item_loc ctxt in
  type_declarations |> List.map (map_type_declaration ~loc)

let generate_intf ~ctxt (_rec_flag, type_declarations) =
  let loc = Expansion_context.Deriver.derived_item_loc ctxt in
  type_declarations |> List.map (map_sig ~loc)

let () =
  let impl_generator = Deriving.Generator.V2.make_noarg generate_impl in
  let intf_generator = Deriving.Generator.V2.make_noarg generate_intf in
  Deriving.add "validate" ~str_type_decl:impl_generator
    ~sig_type_decl:intf_generator
  |> Deriving.ignore