Source file ppx_deriving_gt.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
open Ppxlib
open GTCommon
module E = Expander.Make (PpxHelpers)
let gt_param name =
let open Deriving.Args in
arg name __
;;
let r =
let open Deriving.Args in
map1 ~f:(List.map (fun ({ txt }, e) -> txt, e)) @@ pexp_record __ none
;;
module H = Expander.Make (PpxHelpers)
let str_type_decl : (_, _) Deriving.Generator.t =
Deriving.Generator.make
Deriving.Args.(empty +> arg "options" r)
(fun ~loc ~path info options ->
let generator_f si =
H.str_type_decl_many_plugins
~loc
si
(match options with
| None -> []
| Some xs ->
List.map
(function
| Lident name, e ->
let =
match e.pexp_desc with
| Pexp_record (xs, _) -> List.map (fun ({ txt }, b) -> txt, b) xs
| Pexp_ident { txt = Lident s } when s = name -> []
| _ -> Location.raise_errorf ~loc "bad argument of a plugin"
in
name, Expander.Use extra
| _ -> Location.raise_errorf ~loc "only lowercase identifiers are allowed")
xs)
in
generator_f [] info)
;;
let sig_type_decl : (_, _) Deriving.Generator.t =
Deriving.Generator.make
Deriving.Args.(empty +> arg "options" r)
(fun ~loc ~path info options ->
let generator_f si =
H.sig_type_decl_many_plugins
~loc
si
(match options with
| None -> []
| Some xs ->
List.map
(function
| Lident name, e -> name, Expander.Use []
| _ -> Location.raise_errorf ~loc "only lowercase identifiers are allowed")
xs)
in
generator_f [] info)
;;
let () =
Expander.set_inline_registration (fun name (module M : Plugin_intf.MAKE) ->
let module P = M (PpxHelpers) in
let p =
let loc = Location.none in
let dummy_decl =
match [%stri type nonrec t = int] with
| { pstr_desc = Pstr_type (_, x) } -> x
| _ -> Location.raise_errorf ~loc "Should not happen %s %d" __FILE__ __LINE__
in
P.create [] (false, dummy_decl)
in
let extension ~loc ~path:_ typ =
let names = HelpersBase.vars_from_core_type typ |> HelpersBase.SS.elements in
let tdecl =
let open Ppxlib.Ast_builder.Default in
type_declaration
~loc
~name:(Located.mk ~loc "dummy")
~params:
(List.map
(fun s -> ptyp_var ~loc s, (Asttypes.NoVariance, Asttypes.NoInjectivity))
names)
~cstrs:[]
~private_:Public
~manifest:(Some typ)
~kind:Ptype_abstract
in
let rhs =
p#do_typ_gen
~loc:(PpxHelpers.loc_from_caml loc)
~mutual_decls:[]
~is_self_rec:(fun _ -> `Nonrecursive)
tdecl
typ
in
let open Ppxlib.Ast_builder.Default in
let pats, silence_warns =
p#prepare_fa_args
~loc
(fun ~loc ~flg ~pat ~expr ->
pexp_let ~loc flg [ value_binding ~loc ~pat ~expr ])
tdecl
in
List.fold_right (pexp_fun ~loc Nolabel None) pats (silence_warns rhs)
in
Deriving.add ~extension name |> Deriving.ignore)
;;
let () = Deriving.add ~str_type_decl ~sig_type_decl "gt" |> Deriving.ignore