@@ -28,58 +28,35 @@ let handle_external_in_sig (self : Bs_ast_mapper.mapper)
2828 let loc = prim.pval_loc in
2929 let pval_type = self.typ self prim.pval_type in
3030 let pval_attributes = self.attributes self prim.pval_attributes in
31- match Ast_attributes. process_send_pipe pval_attributes with
32- | Some (obj , _ ) ->
33- (* has bs.send.pipe: best effort *)
34- {
35- sigi with
36- psig_desc =
37- Psig_value
38- {
39- prim with
40- pval_type = Ast_core_type. add_last_obj pval_type obj;
41- pval_prim = [] ;
42- pval_attributes = [] ;
43- };
44- }
45- | None -> (
46- match prim.pval_prim with
47- | [] -> Location. raise_errorf ~loc " empty primitive string"
48- | a :: b :: _ ->
49- Location. raise_errorf ~loc
50- " only a single string is allowed in bs external %S %S"
51- | [v] -> (
52- match
53- Ast_external_process. encode_attributes_as_string loc pval_type
54- pval_attributes v
55- with
56- | {pval_type; pval_prim; pval_attributes; no_inline_cross_module} ->
57- {
58- sigi with
59- psig_desc =
60- Psig_value
61- {
62- prim with
63- pval_type;
64- pval_prim = (if no_inline_cross_module then [] else pval_prim);
65- pval_attributes;
66- };
67- }))
31+ match prim.pval_prim with
32+ | [] -> Location. raise_errorf ~loc " empty primitive string"
33+ | a :: b :: _ ->
34+ Location. raise_errorf ~loc
35+ " only a single string is allowed in bs external %S %S"
36+ | [v] -> (
37+ match
38+ Ast_external_process. encode_attributes_as_string loc pval_type
39+ pval_attributes v
40+ with
41+ | {pval_type; pval_prim; pval_attributes; no_inline_cross_module} ->
42+ {
43+ sigi with
44+ psig_desc =
45+ Psig_value
46+ {
47+ prim with
48+ pval_type;
49+ pval_prim = (if no_inline_cross_module then [] else pval_prim);
50+ pval_attributes;
51+ };
52+ })
6853
6954let handle_external_in_stru (self : Bs_ast_mapper.mapper )
7055 (prim : Parsetree.value_description ) (str : Parsetree.structure_item ) :
7156 Parsetree. structure_item =
7257 let loc = prim.pval_loc in
7358 let pval_type = self.typ self prim.pval_type in
7459 let pval_attributes = self.attributes self prim.pval_attributes in
75- let send_pipe = ref false in
76- let pval_type, pval_attributes =
77- match Ast_attributes. process_send_pipe pval_attributes with
78- | Some (obj , attrs ) ->
79- send_pipe := true ;
80- (Ast_helper.Typ. arrow ~loc Nolabel obj pval_type, attrs)
81- | None -> (pval_type, pval_attributes)
82- in
8360 match prim.pval_prim with
8461 | [] -> Location. raise_errorf ~loc " empty primitive string"
8562 | a :: b :: _ ->
@@ -98,86 +75,24 @@ let handle_external_in_stru (self : Bs_ast_mapper.mapper)
9875 Pstr_primitive {prim with pval_type; pval_prim; pval_attributes};
9976 }
10077 in
101- let normal () =
102- if not no_inline_cross_module then external_result
103- else
104- let open Ast_helper in
105- Str. include_ ~loc
106- (Incl. mk ~loc
107- (Mod. constraint_ ~loc
108- (Mod. structure ~loc [external_result])
109- (Mty. signature ~loc
110- [
111- {
112- psig_desc =
113- Psig_value
114- {
115- prim with
116- pval_type;
117- pval_prim = [] ;
118- pval_attributes;
119- };
120- psig_loc = loc;
121- };
122- ])))
123- in
124- if ! send_pipe then
125- let [@ warning " -8" as args) =
126- Ast_core_type. get_curry_labels pval_type
127- in
128- let arity = List. length args in
129- if arity = 1 then normal ()
130- else
131- let open Ast_helper in
132- Str. include_ ~loc
133- (Incl. mk ~loc
134- (Mod. structure ~loc
135- [
136- external_result;
137- Str. value ~loc Nonrecursive
138- [
139- Vb. mk ~loc
140- (Pat. var ~loc prim.pval_name)
141- (let body =
142- Exp. apply ~loc
143- (Exp. ident ~loc
144- {txt = Lident prim.pval_name.txt; loc})
145- (( Asttypes. Nolabel ,
146- Exp. ident ~loc {txt = Lident " obj"
147- :: Ext_list. mapi params (fun i x ->
148- ( x,
149- match x with
150- | Asttypes. Nolabel ->
151- Exp. ident
152- {
153- txt =
154- Lident
155- (" arg" ^ string_of_int (i + 1 ));
156- loc;
157- }
158- | Labelled s | Optional s ->
159- Exp. ident {txt = Lident s; loc} )))
160- in
161- snd
162- @@ Ext_list. fold_right params
163- ( 0 ,
164- Exp. fun_ Nolabel None
165- (Pat. var ~loc {txt = " obj"
166- body )
167- (fun arg (i , obj ) ->
168- ( i + 1 ,
169- Exp. fun_ arg None
170- (Pat. var ~loc
171- {
172- txt =
173- (match arg with
174- | Labelled s | Optional s -> s
175- | Nolabel ->
176- " arg"
177- ^ string_of_int (arity - i - 1 ));
178- loc;
179- })
180- obj )));
181- ];
182- ]))
183- else normal () )
78+ if not no_inline_cross_module then external_result
79+ else
80+ let open Ast_helper in
81+ Str. include_ ~loc
82+ (Incl. mk ~loc
83+ (Mod. constraint_ ~loc
84+ (Mod. structure ~loc [external_result])
85+ (Mty. signature ~loc
86+ [
87+ {
88+ psig_desc =
89+ Psig_value
90+ {
91+ prim with
92+ pval_type;
93+ pval_prim = [] ;
94+ pval_attributes;
95+ };
96+ psig_loc = loc;
97+ };
98+ ]))))
0 commit comments