forked from rescript-lang/rescript
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathast_derive_projector.ml
178 lines (173 loc) · 7.73 KB
/
ast_derive_projector.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
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
open Ast_helper
let invalid_config (config : Parsetree.expression) =
Location.raise_errorf ~loc:config.pexp_loc
"such configuration is not supported"
let raise_unsupported_vaiant_record_arg loc =
Location.raise_errorf ~loc
"@deriving(accessors) from a variant record argument is unsupported. \
Either define the record type separately from the variant type or use a \
positional argument."
type tdcls = Parsetree.type_declaration list
let deriving_name = "accessors"
let init () =
Ast_derive.register deriving_name (fun (x : Parsetree.expression option) ->
Ext_option.iter x invalid_config;
{
structure_gen =
(fun (tdcls : tdcls) _explict_nonrec ->
let handle_uncurried_accessor_tranform ~loc ~arity accessor =
(* Accessors with no params (arity of 0) are simply values and not functions *)
if arity > 0 then Ast_uncurried.uncurried_fun ~loc ~arity accessor
else accessor
in
let handle_tdcl tdcl =
let core_type =
Ast_derive_util.core_type_of_type_declaration tdcl
in
let gentype_attrs =
match
Ext_list.exists core_type.ptyp_attributes
Ast_attributes.is_gentype
with
| true -> Some [Ast_attributes.gentype]
| false -> None
in
match tdcl.ptype_kind with
| Ptype_record label_declarations ->
Ext_list.map label_declarations
(fun
({pld_name = {loc; txt = pld_label} as pld_name} :
Parsetree.label_declaration)
->
let txt = "param" in
Ast_comb.single_non_rec_value ?attrs:gentype_attrs pld_name
(Ast_compatible.fun_
(Pat.constraint_ (Pat.var {txt; loc}) core_type)
(Exp.field
(Exp.ident {txt = Lident txt; loc})
{txt = Longident.Lident pld_label; loc})
(*arity will alwys be 1 since these are single param functions*)
|> handle_uncurried_accessor_tranform ~arity:1 ~loc))
| Ptype_variant constructor_declarations ->
Ext_list.map constructor_declarations
(fun
{
pcd_name = {loc; txt = con_name};
pcd_args;
pcd_loc;
pcd_res;
}
->
(* TODO: add type annotations *)
let pcd_args =
match pcd_args with
| Pcstr_tuple pcd_args -> pcd_args
| Pcstr_record _ ->
raise_unsupported_vaiant_record_arg pcd_loc
in
let little_con_name =
Ext_string.uncapitalize_ascii con_name
in
let arity = List.length pcd_args in
let annotate_type =
match pcd_res with
| None -> core_type
| Some x -> x
in
Ast_comb.single_non_rec_value ?attrs:gentype_attrs
{loc; txt = little_con_name}
(if arity = 0 then
(*TODO: add a prefix, better inter-op with FFI *)
Exp.constraint_
(Exp.construct
{loc; txt = Longident.Lident con_name}
None)
annotate_type
else
let vars =
Ext_list.init arity (fun x ->
"param_" ^ string_of_int x)
in
let exp =
Exp.constraint_
(Exp.construct
{loc; txt = Longident.Lident con_name}
@@ Some
(if arity = 1 then
Exp.ident
{loc; txt = Lident (List.hd vars)}
else
Exp.tuple
(Ext_list.map vars (fun x ->
Exp.ident {loc; txt = Lident x}))))
annotate_type
in
Ext_list.fold_right vars exp (fun var b ->
Ast_compatible.fun_ (Pat.var {loc; txt = var}) b)
|> handle_uncurried_accessor_tranform ~loc ~arity))
| Ptype_abstract | Ptype_open ->
Ast_derive_util.not_applicable tdcl.ptype_loc deriving_name;
[]
(* Location.raise_errorf "projector only works with record" *)
in
Ext_list.flat_map tdcls handle_tdcl);
signature_gen =
(fun (tdcls : Parsetree.type_declaration list) _explict_nonrec ->
let handle_uncurried_type_tranform ~loc ~arity t =
if arity > 0 then Ast_uncurried.uncurried_type ~loc ~arity t
else t
in
let handle_tdcl tdcl =
let core_type =
Ast_derive_util.core_type_of_type_declaration tdcl
in
let gentype_attrs =
match
Ext_list.exists core_type.ptyp_attributes
Ast_attributes.is_gentype
with
| true -> Some [Ast_attributes.gentype]
| false -> None
in
match tdcl.ptype_kind with
| Ptype_record label_declarations ->
Ext_list.map label_declarations (fun {pld_name; pld_type} ->
Ast_comb.single_non_rec_val ?attrs:gentype_attrs pld_name
(Ast_compatible.arrow core_type pld_type
(*arity will alwys be 1 since these are single param functions*)
|> handle_uncurried_type_tranform ~arity:1
~loc:pld_name.loc))
| Ptype_variant constructor_declarations ->
Ext_list.map constructor_declarations
(fun
{
pcd_name = {loc; txt = con_name};
pcd_args;
pcd_loc;
pcd_res;
}
->
let pcd_args =
match pcd_args with
| Pcstr_tuple pcd_args -> pcd_args
| Pcstr_record _ ->
raise_unsupported_vaiant_record_arg pcd_loc
in
let arity = pcd_args |> List.length in
let annotate_type =
match pcd_res with
| Some x -> x
| None -> core_type
in
Ast_comb.single_non_rec_val ?attrs:gentype_attrs
{loc; txt = Ext_string.uncapitalize_ascii con_name}
(Ext_list.fold_right pcd_args annotate_type (fun x acc ->
Ast_compatible.arrow x acc)
|> handle_uncurried_type_tranform ~arity ~loc))
| Ptype_open | Ptype_abstract ->
Ast_derive_util.not_applicable tdcl.ptype_loc deriving_name;
[]
in
Ext_list.flat_map tdcls handle_tdcl);
expression_gen = None;
})