Source file ppx_yojson_conv.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
(* yojson_conv: Preprocessing Module for Automated Yojson Conversions *)

open Ppxlib
module Attrs = Ppx_yojson_conv_expander.Attrs

module Yojson_of = struct
  module E = Ppx_yojson_conv_expander.Yojson_of

  let name = "yojson_of"

  let str_type_decl =
    Deriving.Generator.make_noarg
      E.str_type_decl
      ~attributes:
        [ Attribute.T Attrs.default
        ; Attribute.T Attrs.drop_default
        ; Attribute.T Attrs.drop_if
        ]
  ;;

  let sig_type_decl = Deriving.Generator.make_noarg E.sig_type_decl
  let extension ~loc:_ ~path:_ ctyp = E.core_type ctyp
  let deriver = Deriving.add name ~str_type_decl ~sig_type_decl ~extension

  let () =
    Driver.register_transformation
      name
      ~rules:
        [ Context_free.Rule.extension
            (Extension.declare
               name
               Core_type
               Ast_pattern.(ptyp __)
               (fun ~loc:_ ~path:_ ty -> E.type_extension ty))
        ]
  ;;
end

module Yojson_fields = struct
  module E = Ppx_yojson_conv_expander.Yojson_fields

  let name = "yojson_fields"
  let str_type_decl = Deriving.Generator.make_noarg E.str_type_decl ~attributes:[]
  let deriver = Deriving.add name ~str_type_decl
end

module Of_yojson = struct
  module E = Ppx_yojson_conv_expander.Of_yojson

  let name = "of_yojson"
  let name' = "of_yojson'"

  let str_type_decl =
    Deriving.Generator.make_noarg
      (E.str_type_decl ~poly:false)
      ~attributes:[ Attribute.T Attrs.default ]
  ;;

  let sig_type_decl = Deriving.Generator.make_noarg (E.sig_type_decl ~poly:false)
  let extension ~loc:_ ~path ctyp = E.core_type ~path ctyp
  let extension' ~loc:_ ~path ctyp = E.core_type' ~path ctyp
  let deriver = Deriving.add name ~str_type_decl ~sig_type_decl ~extension
  let deriver' = Deriving.add name' ~extension:extension'

  let () =
    Driver.register_transformation
      name
      ~rules:
        [ Context_free.Rule.extension
            (Extension.declare
               name
               Core_type
               Ast_pattern.(ptyp __)
               (fun ~loc:_ ~path:_ ty -> E.type_extension ty))
        ]
  ;;

  let () =
    Driver.register_transformation
      name'
      ~rules:
        [ Context_free.Rule.extension
            (Extension.declare
               name'
               Core_type
               Ast_pattern.(ptyp __)
               (fun ~loc:_ ~path:_ ty -> E.type_extension' ty))
        ]
  ;;
end

module Of_yojson_poly = struct
  module E = Ppx_yojson_conv_expander.Of_yojson

  let str_type_decl =
    Deriving.Generator.make_noarg
      (E.str_type_decl ~poly:true)
      ~attributes:[ Attribute.T Attrs.default ]
  ;;

  let sig_type_decl = Deriving.Generator.make_noarg (E.sig_type_decl ~poly:true)
  let deriver = Deriving.add "of_yojson_poly" ~sig_type_decl ~str_type_decl
end

let yojson_of = Yojson_of.deriver
let yojson_fields_of = Yojson_fields.deriver
let of_yojson' = Of_yojson.deriver'
let of_yojson = Of_yojson.deriver
let of_yojson_poly = Of_yojson_poly.deriver

module Yojson_in_sig = struct
  module E = Ppx_yojson_conv_expander.Sig_yojson

  let sig_type_decl = Deriving.Generator.make_noarg E.sig_type_decl

  let deriver =
    Deriving.add
      "ppx_yojson_conv: let this be a string that wouldn't parse if put in the source"
      ~sig_type_decl
  ;;
end

let yojson =
  Deriving.add_alias
    "yojson"
    [ yojson_of; of_yojson ]
    ~sig_type_decl:[ Yojson_in_sig.deriver ]
;;

let yojson_poly = Deriving.add_alias "yojson_poly" [ yojson_of; of_yojson_poly ]

let _ =
  let primitives =
    Longident.parse (Printf.sprintf "Ppx_yojson_conv_lib.Yojson_conv.Primitives")
  in
  Driver.register_transformation "Ppx_yojson_conv.enclose_impl" ~enclose_impl:(function
    | None -> [], []
    | Some loc ->
      let loc = { loc with loc_end = loc.loc_start } in
      ( [ Ast_builder.Default.(
          pstr_open
            ~loc
            (open_description
               ~loc
               ~lid:(Located.mk ~loc primitives)
               ~override:Override))
        ]
      , [] ))
;;