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.2.0.tbz

sha256=1654b5cce9c367a56127094dced317f865c9562599f209f70506a32b6b65154b

sha512=467ea81c0be6057ae5b8702f739e4d4f87e2707d2e09e12abd981cc2836b0f13ebab308c68954e64ea3ce89850aa0ac6df7944b596f70287fb99bdf326edcd46

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
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
open Ppxlib
open Ast_helper
open Validators
open Utils

let map_type_declaration ~loc td =
  let body =
    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

        Exp.(
          apply
            (ident
               {
                 txt = Ldot (Lident "Validate", "validate");
                 loc = td.ptype_loc;
               })
            [ (Nolabel, body) ])
    | Ptype_abstract ->
        let validators =
          td.ptype_manifest |> Option.get |> type_validator_exp
        in
        (* Printf.printf "%s\n" (Pprintast.string_of_expression validators); *)
        Exp.(
          apply
            (ident
               {
                 txt = Ldot (Lident "Validate", "validate");
                 loc = td.ptype_loc;
               })
            [ (Nolabel, validators) ])
    | _ -> Location.raise_errorf ~loc "Unsupported type"
  in
  let type_name = td.ptype_name.txt in
  let function_name = "validate_" ^ type_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

let map_sig ~loc td =
  match td.ptype_kind with
  | Ptype_abstract | 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