forked from rescript-lang/rescript
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathast_derive_projector.ml
134 lines (130 loc) · 5.83 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
open Ast_helper
let invalid_config (config : Parsetree.expression) =
Location.raise_errorf ~loc:config.pexp_loc
"such configuration is not supported"
type tdcls = Parsetree.type_declaration list
let derivingName = "accessors"
let init () =
Ast_derive.register derivingName (fun (x : Parsetree.expression option) ->
Ext_option.iter x invalid_config;
{
structure_gen =
(fun (tdcls : tdcls) _explict_nonrec ->
let handle_tdcl tdcl =
let core_type =
Ast_derive_util.core_type_of_type_declaration tdcl
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 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 })))
| 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 _ -> assert false
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
{ 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)))
| Ptype_abstract | Ptype_open ->
Ast_derive_util.notApplicable tdcl.ptype_loc derivingName;
[]
(* 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_tdcl tdcl =
let core_type =
Ast_derive_util.core_type_of_type_declaration tdcl
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 pld_name
(Ast_compatible.arrow core_type pld_type))
| 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 _ -> assert false
in
let annotate_type =
match pcd_res with Some x -> x | None -> core_type
in
Ast_comb.single_non_rec_val
{ loc; txt = Ext_string.uncapitalize_ascii con_name }
(Ext_list.fold_right pcd_args annotate_type
(fun x acc -> Ast_compatible.arrow x acc)))
| Ptype_open | Ptype_abstract ->
Ast_derive_util.notApplicable tdcl.ptype_loc derivingName;
[]
in
Ext_list.flat_map tdcls handle_tdcl);
expression_gen = None;
})