package validate

You can search for identifiers within the package.

in-package search v0.2.0

OCaml library enabling efficient data validation through PPX derivers and a suite of annotation-based validators

Install

Dune Dependency

github.com Readme Changelog Edit opam file Versions (4)

Authors

M

Mateusz Ledwoń <mateuszledwon@duck.com>

Maintainers

M

Mateusz Ledwoń <mateuszledwon@duck.com>

Sources

validate-0.1.0.tbz

sha256=7b3e8978f003d5af74b182c476bbf829572000dd53e7d72ed98cecd4c4b26daf

sha512=ce9f0be079fff7a9250756384954e36e6b12376b5b1b7a75d7c88a14eb323758048faa906a47c7e36ed65854014c549457be6f4f4a6d9cce6be7c52f108b354c

doc/src/ppx_derive_validate/ppx_derive_validate.ml.html

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