1+ (* Copyright (C) 2017 Authors of BuckleScript
2+ *
3+ * This program is free software: you can redistribute it and/or modify
4+ * it under the terms of the GNU Lesser General Public License as published by
5+ * the Free Software Foundation, either version 3 of the License, or
6+ * (at your option) any later version.
7+ *
8+ * In addition to the permissions granted to you by the LGPL, you may combine
9+ * or link a "work that uses the Library" with a publicly distributed version
10+ * of this file to produce a combined library or application, then distribute
11+ * that combined work under the terms of your choosing, with no requirement
12+ * to comply with the obligations normally placed on you by section 4 of the
13+ * LGPL version 3 (or the corresponding section of a later version of the LGPL
14+ * should you choose to use a later version).
15+ *
16+ * This program is distributed in the hope that it will be useful,
17+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
18+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19+ * GNU Lesser General Public License for more details.
20+ *
21+ * You should have received a copy of the GNU Lesser General Public License
22+ * along with this program; if not, write to the Free Software
23+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
24+
25+ open Ast_helper
26+
27+ type tdcls = Parsetree .type_declaration list
28+
29+ let js_field (o : Parsetree.expression ) m =
30+ Exp. apply
31+ (Exp. ident {txt = Lident " ##" = o.pexp_loc})
32+ [
33+ " "
34+ " " Exp. ident m
35+ ]
36+
37+ let invalid_config (config : Parsetree.expression ) =
38+ Location. raise_errorf ~loc: config.pexp_loc " such configuration is not supported"
39+
40+ let init () =
41+ Ast_derive. register
42+ " jsMapper"
43+ (fun ( x : Parsetree.expression option ) ->
44+ (match x with
45+ | Some config -> invalid_config config
46+ | None -> () );
47+ {
48+ structure_gen = (fun (tdcls : tdcls ) _ ->
49+ let handle_tdcl tdcl =
50+ let core_type = Ast_derive_util. core_type_of_type_declaration tdcl
51+ in
52+ let name = tdcl.ptype_name.txt in
53+ let toJs = name ^ " ToJs" in
54+ let fromJs = name ^ " FromJs" in
55+ match tdcl.ptype_kind with
56+ | Ptype_record label_declarations ->
57+ let record_arg = " record" in
58+ let exp =
59+ Exp. record
60+ (List. map
61+ (fun ({pld_name = {loc; txt } } : Parsetree.label_declaration ) ->
62+ {Asttypes. loc; txt = Longident. Lident txt },
63+ Exp. field (Exp. ident {txt = Lident record_arg ; loc })
64+ {Asttypes. loc; txt = Longident. Lident txt }
65+ ) label_declarations) None in
66+ let loc = tdcl.ptype_loc in
67+ let toJs = Ast_comb. single_non_rec_value {loc; txt = toJs}
68+ (Exp. fun_ " " None (Pat. constraint_ (Pat. var {loc; txt = record_arg}) core_type)
69+ (Exp. extension ({Asttypes. loc; txt = " bs.obj" PStr [Str. eval exp ]))))
70+ in
71+ let obj_arg = " obj" in
72+ let obj_exp =
73+ Exp. record
74+ (List. map
75+ (fun ({pld_name = {loc; txt } } : Parsetree.label_declaration ) ->
76+ {Asttypes. loc; txt = Longident. Lident txt },
77+ js_field (Exp. ident {txt = Lident obj_arg ; loc })
78+ {Asttypes. loc; txt = Longident. Lident txt }
79+ ) label_declarations) None in
80+ let fromJs =
81+ Ast_comb. single_non_rec_value {loc; txt = fromJs}
82+ (Exp. fun_ " " None (Pat. var {loc; txt = obj_arg})
83+ (Exp. constraint_ obj_exp core_type) )
84+ in
85+ [
86+ toJs;
87+ fromJs
88+ ]
89+ | Ptype_variant _
90+ | Ptype_abstract | Ptype_open -> [] in
91+ Ext_list. flat_map handle_tdcl tdcls
92+ );
93+ signature_gen =
94+ (fun (tdcls : tdcls ) _ ->
95+ let handle_tdcl tdcl =
96+ let core_type = Ast_derive_util. core_type_of_type_declaration tdcl
97+ in
98+ let name = tdcl.ptype_name.txt in
99+ let toJs = name ^ " ToJs" in
100+ let fromJs = name ^ " FromJs" in
101+ match tdcl.ptype_kind with
102+ | Ptype_record label_declarations ->
103+ let loc = tdcl.ptype_loc in
104+ let ty =
105+ Ast_comb. to_js_type loc @@
106+ Typ. object_
107+ (List. map
108+ (fun ({pld_name = {loc; txt } ; pld_type } : Parsetree.label_declaration ) ->
109+ txt, [] , pld_type
110+ ) label_declarations)
111+ Closed in
112+ let loc = tdcl.ptype_loc in
113+ let toJs =
114+ Ast_comb. single_non_rec_val {loc; txt = toJs}
115+ (Typ. arrow " " in
116+ let fromJs =
117+ Ast_comb. single_non_rec_val {loc; txt = fromJs}
118+ (Typ. arrow " " in
119+ [
120+ toJs;
121+ fromJs
122+ ]
123+ | Ptype_variant _
124+ | Ptype_abstract | Ptype_open -> [] in
125+ Ext_list. flat_map handle_tdcl tdcls
126+
127+ );
128+ expression_gen = None
129+ }
130+ )
131+ ;
0 commit comments