forked from rescript-lang/rescript
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathast_derive_projector.ml
119 lines (108 loc) · 5.45 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
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 =
begin 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
begin
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
)
end)
)
| 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
end;
signature_gen =
begin 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
end;
expression_gen = None
}
)