From a9a9076bd2273f0ecb2ce2c96c9b57db7c41631d Mon Sep 17 00:00:00 2001 From: Hongbo Zhang Date: Wed, 1 Jun 2016 10:15:12 -0400 Subject: [PATCH 1/3] [refactoring] clean up arity which does not depend on type info anymore --- jscomp/js_dump.ml | 4 +- jscomp/js_op.ml | 2 +- jscomp/lam_compile_external_call.ml | 18 ++++---- jscomp/lam_dispatch_primitive.ml | 2 +- jscomp/lam_stats_util.ml | 20 ++++----- jscomp/syntax/ast_payload.ml | 69 +++++++++++++++++++++++++++++ jscomp/syntax/ast_payload.mli | 35 +++++++++++++++ jscomp/syntax/parsetree_util.ml | 40 +---------------- jscomp/syntax/parsetree_util.mli | 7 +-- jscomp/syntax/syntax.mllib | 1 + 10 files changed, 132 insertions(+), 66 deletions(-) create mode 100644 jscomp/syntax/ast_payload.ml create mode 100644 jscomp/syntax/ast_payload.mli diff --git a/jscomp/js_dump.ml b/jscomp/js_dump.ml index 0e785a1f3b..0ef86cf9fa 100644 --- a/jscomp/js_dump.ml +++ b/jscomp/js_dump.ml @@ -643,7 +643,7 @@ and pp_string f (* ~utf:(kind = `Utf8) *) ~quote s; cxt | Raw_js_code (s,info) -> begin match info with - | Exp _ -> + | Exp -> P.string f "("; P.string f s ; P.string f ")"; @@ -1147,7 +1147,7 @@ and statement_desc top cxt f (s : J.statement_desc) : Ext_pp_scope.t = match e.expression_desc with | Call ({expression_desc = Fun _; },_,_) -> true | Caml_uninitialized_obj _ - | Raw_js_code (_, Exp _) + | Raw_js_code (_, Exp) | Fun _ | Object _ -> true | Raw_js_code (_,Stmt) | Caml_block_set_tag _ diff --git a/jscomp/js_op.ml b/jscomp/js_op.ml index e64bdd9ed5..05e232d097 100644 --- a/jscomp/js_op.ml +++ b/jscomp/js_op.ml @@ -247,7 +247,7 @@ type length_object = | Caml_block type code_info = - | Exp of int option + | Exp (* of int option *) | Stmt (** TODO: define constant - for better constant folding *) (* type constant = *) diff --git a/jscomp/lam_compile_external_call.ml b/jscomp/lam_compile_external_call.ml index 02de65d9d2..1d7f6b6a3f 100644 --- a/jscomp/lam_compile_external_call.ml +++ b/jscomp/lam_compile_external_call.ml @@ -31,7 +31,7 @@ module E = Js_exp_make -open Parsetree_util + type external_module_name = | Single of string @@ -141,7 +141,7 @@ let handle_attributes ({prim_attributes ; prim_name} as _prim : prim ) : Locati ]} *) -> - begin match is_single_string pay_load with + begin match Ast_payload.is_single_string pay_load with | Some name -> js_val := `Value name | None -> @@ -152,7 +152,7 @@ let handle_attributes ({prim_attributes ; prim_name} as _prim : prim ) : Locati (* {[ [@@bs.val_of_module]]} *) -> - begin match is_single_string pay_load with + begin match Ast_payload.is_single_string pay_load with | Some name -> js_val_of_module := `Value(Bind (name, prim_name)) | None -> @@ -164,19 +164,19 @@ let handle_attributes ({prim_attributes ; prim_name} as _prim : prim ) : Locati |"bs.send" -> - begin match is_single_string pay_load with + begin match Ast_payload.is_single_string pay_load with | Some name -> js_send := `Value name | None -> js_send := `Value _prim.prim_name end | "bs.set" -> - begin match is_single_string pay_load with + begin match Ast_payload.is_single_string pay_load with | Some name -> js_set := `Value name | None -> js_set := `Value _prim.prim_name end | "bs.get" -> - begin match is_single_string pay_load with + begin match Ast_payload.is_single_string pay_load with | Some name -> js_get := `Value name | None -> js_get := `Value _prim.prim_name end @@ -186,12 +186,12 @@ let handle_attributes ({prim_attributes ; prim_name} as _prim : prim ) : Locati [@@bs.call "xx"] [@@bs.call] *) -> - begin match is_single_string pay_load with + begin match Ast_payload.is_single_string pay_load with | Some name -> call_name := Some (x.loc, name) | None -> call_name := Some(x.loc, _prim.prim_name) end | "bs.module" -> - begin match is_string_or_strings pay_load with + begin match Ast_payload.is_string_or_strings pay_load with | `Single name -> external_module_name:= Some (Single name) | `Some [a;b] -> external_module_name := Some (Bind (a,b)) | `Some _ -> () @@ -199,7 +199,7 @@ let handle_attributes ({prim_attributes ; prim_name} as _prim : prim ) : Locati end | "bs.new" -> - begin match is_single_string pay_load with + begin match Ast_payload.is_single_string pay_load with | Some x -> js_new := Some x | None -> js_new := Some _prim.prim_name end diff --git a/jscomp/lam_dispatch_primitive.ml b/jscomp/lam_dispatch_primitive.ml index f9ee80aa52..c43f8401b0 100644 --- a/jscomp/lam_dispatch_primitive.ml +++ b/jscomp/lam_dispatch_primitive.ml @@ -940,7 +940,7 @@ let query (prim : Lam_compile_env.primitive_description) -> begin match args with | [ { expression_desc = Str (_,s )}] -> - E.raw_js_code (Exp (Parsetree_util.has_arity prim.prim_attributes)) s + E.raw_js_code Exp s | _ -> Ext_log.err __LOC__ "JS.unsafe_js_expr is applied to an non literal string in %s" diff --git a/jscomp/lam_stats_util.ml b/jscomp/lam_stats_util.ml index 212e1f04d2..4eb51cc384 100644 --- a/jscomp/lam_stats_util.ml +++ b/jscomp/lam_stats_util.ml @@ -92,16 +92,16 @@ let rec get_arity end | Llet(_,_,_, l ) -> get_arity meta l - | Lprim (Pccall {prim_name = "js_pure_expr"; prim_attributes}, - [Lconst (Const_base (Const_string (_str,_)))]) - -> - (* Ext_log.dwarn __LOC__ "called %s %d" str (List.length prim_attributes ); *) - begin match Parsetree_util.has_arity prim_attributes with - | Some arity -> - (* Ext_log.dwarn __LOC__ "arity %d" arity; *) - Determin(false, [arity, None], false) - | None -> NA - end + (* | Lprim (Pccall {prim_name = "js_pure_expr"; prim_attributes}, *) + (* [Lconst (Const_base (Const_string (_str,_)))]) *) + (* -> *) + (* (\* Ext_log.dwarn __LOC__ "called %s %d" str (List.length prim_attributes ); *\) *) + (* begin match Parsetree_util.has_arity prim_attributes with *) + (* | Some arity -> *) + (* (\* Ext_log.dwarn __LOC__ "arity %d" arity; *\) *) + (* Determin(false, [arity, None], false) *) + (* | None -> NA *) + (* end *) | Lprim (Pfield (n,_), [Lprim(Pgetglobal id,[])]) -> Lam_compile_env.find_and_add_if_not_exist (id, n) meta.env ~not_found:(fun _ -> assert false) diff --git a/jscomp/syntax/ast_payload.ml b/jscomp/syntax/ast_payload.ml new file mode 100644 index 0000000000..51c260f1cb --- /dev/null +++ b/jscomp/syntax/ast_payload.ml @@ -0,0 +1,69 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +type t = Parsetree.payload + +let is_single_string (x : t ) = + match x with (** TODO also need detect empty phrase case *) + | PStr [ { + pstr_desc = + Pstr_eval ( + {pexp_desc = + Pexp_constant + (Const_string (name,_)); + _},_); + _}] -> Some name + | _ -> None + + +let is_string_or_strings (x : t) : + [ `None | `Single of string | `Some of string list ] = + let module M = struct exception Not_str end in + match x with + | PStr [ {pstr_desc = + Pstr_eval ( + {pexp_desc = + Pexp_apply + ({pexp_desc = Pexp_constant (Const_string (name,_)); _}, + args + ); + _},_); + _}] -> + (try + `Some (name :: (args |> List.map (fun (_label,e) -> + match (e : Parsetree.expression) with + | {pexp_desc = Pexp_constant (Const_string (name,_)); _} -> + name + | _ -> raise M.Not_str))) + + with M.Not_str -> `None ) + | PStr [ { + pstr_desc = + Pstr_eval ( + {pexp_desc = + Pexp_constant + (Const_string (name,_)); + _},_); + _}] -> `Single name + | _ -> `None diff --git a/jscomp/syntax/ast_payload.mli b/jscomp/syntax/ast_payload.mli new file mode 100644 index 0000000000..78df4b087c --- /dev/null +++ b/jscomp/syntax/ast_payload.mli @@ -0,0 +1,35 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + + + +(** A utility module used when destructuring parsetree attributes, used for + compiling FFI attributes and built-in ppx *) + +type t = Parsetree.payload + +val is_single_string : t -> string option + +val is_string_or_strings : + t -> [ `None | `Single of string | `Some of string list ] diff --git a/jscomp/syntax/parsetree_util.ml b/jscomp/syntax/parsetree_util.ml index 9ac2b1369f..a0db5032b2 100644 --- a/jscomp/syntax/parsetree_util.ml +++ b/jscomp/syntax/parsetree_util.ml @@ -41,7 +41,8 @@ let is_single_string (x : Parsetree.payload ) = _}] -> Some name | _ -> None -let is_string_or_strings (x : Parsetree.payload ) : [ `None | `Single of string | `Some of string list ] = +let is_string_or_strings (x : Parsetree.payload ) : + [ `None | `Single of string | `Some of string list ] = let module M = struct exception Not_str end in match x with | PStr [ {pstr_desc = @@ -74,40 +75,3 @@ let is_string_or_strings (x : Parsetree.payload ) : [ `None | `Single of string let lift_int ?loc ?attrs x = Ast_helper.Exp.constant ?loc ?attrs (Const_int x) -let has_arity (attrs : Parsetree.attributes) = - Ext_list.find_opt (fun (attr : Parsetree.attribute) -> - match attr with - | {txt = "arity"; _ }, - PStr [ { pstr_desc = Pstr_eval - ( {pexp_desc = Pexp_constant (Const_int i)},_attr); - _}] - -> - if i >= 0 then - Some i - else None - | _ -> None - ) attrs - - - -let arity_from_core_type (x : Parsetree.core_type) = - let rec aux acc (x : Parsetree.core_type) = - match x.ptyp_desc with - | Ptyp_arrow (_,_,r) -> - (* 'a -> ('b -> ('c -> 'd )) *) - aux (acc + 1) r - | _ -> acc in - aux 0 x - - - -let attr_attribute_from_type (x : Parsetree.core_type) : Parsetree.attribute = - let n = arity_from_core_type x in - let loc = x.ptyp_loc in - {txt = "arity"; loc}, - PStr ([ {pstr_desc = - Pstr_eval (lift_int n,[]); - pstr_loc = loc - }]) - - diff --git a/jscomp/syntax/parsetree_util.mli b/jscomp/syntax/parsetree_util.mli index cde85cacab..cee43597a7 100644 --- a/jscomp/syntax/parsetree_util.mli +++ b/jscomp/syntax/parsetree_util.mli @@ -33,10 +33,7 @@ compiling FFI code *) -val is_single_string : Parsetree.payload -> string option +(* val is_single_string : Parsetree.payload -> string option *) -val is_string_or_strings : Parsetree.payload -> [ `None | `Single of string | `Some of string list ] +(* val is_string_or_strings : Parsetree.payload -> [ `None | `Single of string | `Some of string list ] *) -val has_arity : Parsetree.attributes -> int option - -val attr_attribute_from_type : Parsetree.core_type -> Parsetree.attribute diff --git a/jscomp/syntax/syntax.mllib b/jscomp/syntax/syntax.mllib index 3f83f675d4..490613563f 100644 --- a/jscomp/syntax/syntax.mllib +++ b/jscomp/syntax/syntax.mllib @@ -1,2 +1,3 @@ parsetree_util +ast_payload ppx_entry \ No newline at end of file From 2cb684b001d761b890ec53144aa4ce904045f24d Mon Sep 17 00:00:00 2001 From: Hongbo Zhang Date: Wed, 1 Jun 2016 12:57:28 -0400 Subject: [PATCH 2/3] [refact & bug fix] type var difference from type constructor --- jscomp/syntax/ast_comb.ml | 58 ++++++ .../{parsetree_util.mli => ast_comb.mli} | 22 +-- .../syntax/{parsetree_util.ml => ast_lift.ml} | 53 +----- jscomp/syntax/ast_lift.mli | 27 +++ jscomp/syntax/ast_literal.ml | 78 ++++++++ jscomp/syntax/ast_literal.mli | 49 +++++ jscomp/syntax/ast_payload.ml | 11 ++ jscomp/syntax/ast_payload.mli | 1 + jscomp/syntax/ppx_entry.ml | 172 ++++++------------ jscomp/syntax/syntax.mllib | 6 +- 10 files changed, 291 insertions(+), 186 deletions(-) create mode 100644 jscomp/syntax/ast_comb.ml rename jscomp/syntax/{parsetree_util.mli => ast_comb.mli} (82%) rename jscomp/syntax/{parsetree_util.ml => ast_lift.ml} (50%) create mode 100644 jscomp/syntax/ast_lift.mli create mode 100644 jscomp/syntax/ast_literal.ml create mode 100644 jscomp/syntax/ast_literal.mli diff --git a/jscomp/syntax/ast_comb.ml b/jscomp/syntax/ast_comb.ml new file mode 100644 index 0000000000..6331e42a71 --- /dev/null +++ b/jscomp/syntax/ast_comb.ml @@ -0,0 +1,58 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +let create_local_external loc + ?(pval_attributes=[]) + ~pval_prim + ~pval_type + ?(local_module_name = "J") + ?(local_fun_name = "unsafe_expr") + args + : Parsetree.expression_desc = + Pexp_letmodule + ({txt = local_module_name; loc}, + {pmod_desc = + Pmod_structure + [{pstr_desc = + Pstr_primitive + {pval_name = {txt = local_fun_name; loc}; + pval_type ; + pval_loc = loc; + pval_prim = [pval_prim]; + pval_attributes }; + pstr_loc = loc; + }]; + pmod_loc = loc; + pmod_attributes = []}, + { + pexp_desc = + Pexp_apply + (({pexp_desc = Pexp_ident {txt = Ldot (Lident local_module_name, local_fun_name); + loc}; + pexp_attributes = [] ; + pexp_loc = loc} : Parsetree.expression), + args); + pexp_attributes = []; + pexp_loc = loc + }) diff --git a/jscomp/syntax/parsetree_util.mli b/jscomp/syntax/ast_comb.mli similarity index 82% rename from jscomp/syntax/parsetree_util.mli rename to jscomp/syntax/ast_comb.mli index cee43597a7..ad85df3f06 100644 --- a/jscomp/syntax/parsetree_util.mli +++ b/jscomp/syntax/ast_comb.mli @@ -22,18 +22,10 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - - - - - - - -(* A utility module used when destructuring parsetree attributes, used for - compiling FFI code - *) - -(* val is_single_string : Parsetree.payload -> string option *) - -(* val is_string_or_strings : Parsetree.payload -> [ `None | `Single of string | `Some of string list ] *) - +val create_local_external : Location.t -> + ?pval_attributes:Parsetree.attributes -> + pval_prim:string -> + pval_type:Parsetree.core_type -> + ?local_module_name:string -> + ?local_fun_name:string -> + (Asttypes.label * Parsetree.expression) list -> Parsetree.expression_desc diff --git a/jscomp/syntax/parsetree_util.ml b/jscomp/syntax/ast_lift.ml similarity index 50% rename from jscomp/syntax/parsetree_util.ml rename to jscomp/syntax/ast_lift.ml index a0db5032b2..4299461752 100644 --- a/jscomp/syntax/parsetree_util.ml +++ b/jscomp/syntax/ast_lift.ml @@ -22,56 +22,5 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - - - - - - - -let is_single_string (x : Parsetree.payload ) = - match x with (** TODO also need detect empty phrase case *) - | Parsetree.PStr [ { - pstr_desc = - Pstr_eval ( - {pexp_desc = - Pexp_constant - (Const_string (name,_)); - _},_); - _}] -> Some name - | _ -> None - -let is_string_or_strings (x : Parsetree.payload ) : - [ `None | `Single of string | `Some of string list ] = - let module M = struct exception Not_str end in - match x with - | PStr [ {pstr_desc = - Pstr_eval ( - {pexp_desc = - Pexp_apply - ({pexp_desc = Pexp_constant (Const_string (name,_)); _}, - args - ); - _},_); - _}] -> - (try - `Some (name :: (args |> List.map (fun (_label,e) -> - match (e : Parsetree.expression) with - | {pexp_desc = Pexp_constant (Const_string (name,_)); _} -> - name - | _ -> raise M.Not_str))) - - with M.Not_str -> `None ) - | Parsetree.PStr [ { - pstr_desc = - Pstr_eval ( - {pexp_desc = - Pexp_constant - (Const_string (name,_)); - _},_); - _}] -> `Single name - | _ -> `None - -let lift_int ?loc ?attrs x = +let int ?loc ?attrs x = Ast_helper.Exp.constant ?loc ?attrs (Const_int x) - diff --git a/jscomp/syntax/ast_lift.mli b/jscomp/syntax/ast_lift.mli new file mode 100644 index 0000000000..1bc1fc6139 --- /dev/null +++ b/jscomp/syntax/ast_lift.mli @@ -0,0 +1,27 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +val int : + ?loc:Location.t -> + ?attrs:Parsetree.attributes -> int -> Parsetree.expression diff --git a/jscomp/syntax/ast_literal.ml b/jscomp/syntax/ast_literal.ml new file mode 100644 index 0000000000..b16d93145d --- /dev/null +++ b/jscomp/syntax/ast_literal.ml @@ -0,0 +1,78 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +module Lid = struct + type t = Longident.t + let val_unit : t = Lident "()" + let type_unit : t = Lident "unit" + let type_string : t = Lident "string" + (* TODO should be renamed in to {!Js.fn} *) + (* TODO should be moved into {!Js.t} Later *) + let pervasives_js_obj = Longident.Ldot (Lident "Pervasives", "js_obj") + let pervasives_uncurry = Longident.Ldot (Lident "Pervasives", "uncurry") + let js_obj = Longident.Ldot (Lident "Js", "t") + let js_fn = Longident.Ldot (Lident "Js", "fn") + let ignore_id = Longident.Ldot (Lident "Pervasives", "ignore") +end + +module No_loc = struct + let loc = Location.none + let val_unit = + Ast_helper.Exp.construct {txt = Lid.val_unit; loc } None + let type_unit = + Ast_helper.Typ.mk (Ptyp_constr ({ txt = Lid.type_unit; loc}, [])) + + let type_string = + Ast_helper.Typ.mk (Ptyp_constr ({ txt = Lid.type_string; loc}, [])) + + let type_any = Ast_helper.Typ.any () +end + +type 'a lit = ?loc: Location.t -> unit -> 'a +type expression_lit = Parsetree.expression lit +type core_type_lit = Parsetree.core_type lit +let val_unit ?loc () = + match loc with + | None -> No_loc.val_unit + | Some loc -> Ast_helper.Exp.construct {txt = Lid.val_unit; loc} None + + +let type_unit ?loc () = + match loc with + | None -> + No_loc.type_unit + | Some loc -> + Ast_helper.Typ.mk ~loc (Ptyp_constr ({ txt = Lid.type_unit; loc}, [])) + + +let type_string ?loc () = + match loc with + | None -> No_loc.type_string + | Some loc -> + Ast_helper.Typ.mk ~loc (Ptyp_constr ({ txt = Lid.type_string; loc}, [])) + +let type_any ?loc () = + match loc with + | None -> No_loc.type_any + | Some loc -> Ast_helper.Typ.any ~loc () diff --git a/jscomp/syntax/ast_literal.mli b/jscomp/syntax/ast_literal.mli new file mode 100644 index 0000000000..0ff9e378cc --- /dev/null +++ b/jscomp/syntax/ast_literal.mli @@ -0,0 +1,49 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + + +type 'a lit = ?loc: Location.t -> unit -> 'a +module Lid : sig + type t = Longident.t + val val_unit : t + val type_unit : t + val pervasives_js_obj : t + val pervasives_uncurry : t + val js_obj : t + val js_fn : t + val ignore_id : t +end + +type expression_lit = Parsetree.expression lit +type core_type_lit = Parsetree.core_type lit + +val val_unit : expression_lit + +val type_unit : core_type_lit + +val type_string : core_type_lit + +val type_any : core_type_lit + + diff --git a/jscomp/syntax/ast_payload.ml b/jscomp/syntax/ast_payload.ml index 51c260f1cb..33aae6800b 100644 --- a/jscomp/syntax/ast_payload.ml +++ b/jscomp/syntax/ast_payload.ml @@ -36,6 +36,17 @@ let is_single_string (x : t ) = _}] -> Some name | _ -> None +let as_string_exp (x : t ) = + match x with (** TODO also need detect empty phrase case *) + | PStr [ { + pstr_desc = + Pstr_eval ( + {pexp_desc = + Pexp_constant + (Const_string (_,_)); + _} as e ,_); + _}] -> Some e + | _ -> None let is_string_or_strings (x : t) : [ `None | `Single of string | `Some of string list ] = diff --git a/jscomp/syntax/ast_payload.mli b/jscomp/syntax/ast_payload.mli index 78df4b087c..50fa5d5766 100644 --- a/jscomp/syntax/ast_payload.mli +++ b/jscomp/syntax/ast_payload.mli @@ -30,6 +30,7 @@ type t = Parsetree.payload val is_single_string : t -> string option +val as_string_exp : t -> Parsetree.expression option val is_string_or_strings : t -> [ `None | `Single of string | `Some of string list ] diff --git a/jscomp/syntax/ppx_entry.ml b/jscomp/syntax/ppx_entry.ml index cc688d7042..38276d8455 100644 --- a/jscomp/syntax/ppx_entry.ml +++ b/jscomp/syntax/ppx_entry.ml @@ -55,36 +55,22 @@ let tmp_module_name = "J" let tmp_fn = "unsafe_expr" -let predef_string_type = - Ast_helper.Typ.var "string" -let predef_any_type = - Ast_helper.Typ.any () -let predef_unit_type = - Ast_helper.Typ.var "unit" -let predef_val_unit = - Ast_helper.Exp.construct {txt = Lident "()"; loc = Location.none } None -let prim = "js_pure_expr" + let prim_stmt = "js_pure_stmt" -let prim_debugger = "js_debugger" - -(* TODO should be renamed in to {!Js.fn} *) -(* TODO should be moved into {!Js.t} Later *) -let pervasives_js_obj = Longident.Ldot (Lident "Pervasives", "js_obj") -let pervasives_uncurry = Longident.Ldot (Lident "Pervasives", "uncurry") -let js_obj = Longident.Ldot (Lident "Js", "t") -let js_fn = Longident.Ldot (Lident "Js", "fn") + + let js_obj_type_id () = if Js_config.get_env () = Browser then - pervasives_js_obj - else js_obj + Ast_literal.Lid.pervasives_js_obj + else Ast_literal.Lid.js_obj let curry_type_id () = if Js_config.get_env () = Browser then - pervasives_uncurry + Ast_literal.Lid.pervasives_uncurry else - js_fn + Ast_literal.Lid.js_fn + -let ignore_id = Longident.Ldot (Lident "Pervasives", "ignore") let arrow = Ast_helper.Typ.arrow @@ -98,7 +84,7 @@ let discard_js_value loc e : Parsetree.expression = {pexp_desc = Pexp_apply ({pexp_desc = - Pexp_ident {txt = ignore_id ; loc}; + Pexp_ident {txt = Ast_literal.Lid.ignore_id ; loc}; pexp_attributes = []; pexp_loc = loc}, [("", @@ -116,40 +102,6 @@ let discard_js_value loc e : Parsetree.expression = } -let create_local_external loc - ~pval_prim - ~pval_type ~pval_attributes - local_module_name - local_fun_name - args - : Parsetree.expression_desc = - Pexp_letmodule - ({txt = local_module_name; loc}, - {pmod_desc = - Pmod_structure - [{pstr_desc = - Pstr_primitive - {pval_name = {txt = local_fun_name; loc}; - pval_type ; - pval_loc = loc; - pval_prim = [pval_prim]; - pval_attributes }; - pstr_loc = loc; - }]; - pmod_loc = loc; - pmod_attributes = []}, - { - pexp_desc = - Pexp_apply - (({pexp_desc = Pexp_ident {txt = Ldot (Lident local_module_name, local_fun_name); - loc}; - pexp_attributes = [] ; - pexp_loc = loc} : Parsetree.expression), - args); - pexp_attributes = []; - pexp_loc = loc - }) - let record_as_js_object = ref None (* otherwise has an attribute *) let obj_type_as_js_obj_type = ref false let handle_record_as_js_object @@ -166,8 +118,6 @@ let handle_record_as_js_object ) label_exprs in let pval_prim = "" in let pval_attributes = [attr] in - let local_module_name = "Tmp" in - let local_fun_name = "run" in let pval_type = let arity = List.length labels in let tyvars = (Ext_list.init arity (fun i -> @@ -189,18 +139,18 @@ let handle_record_as_js_object List.fold_right2 (fun label tyvar acc -> arrow ~loc label tyvar acc) labels tyvars result_type in - create_local_external loc + let local_module_name = "Tmp" in + let local_fun_name = "run" in + Ast_comb.create_local_external loc ~pval_prim ~pval_type ~pval_attributes - local_module_name - local_fun_name + ~local_module_name + ~local_fun_name args let gen_fn_run loc arity args : Parsetree.expression_desc = let open Parsetree in let ptyp_attributes = [] in - let local_module_name = "Tmp" in - let local_fun_name = "run" in let pval_prim = Printf.sprintf "js_fn_run_%02d" arity in let tyvars = (Ext_list.init (arity + 1) (fun i -> @@ -225,14 +175,14 @@ let gen_fn_run loc arity args : Parsetree.expression_desc = (** could be optimized *) let pval_type = Ext_list.reduce_from_right (fun a b -> arrow ~loc "" a b) (uncurry_fn :: tyvars) in - create_local_external loc ~pval_prim ~pval_type ~pval_attributes:[] - local_module_name local_fun_name args + let local_module_name = "Tmp" in + let local_fun_name = "run" in + Ast_comb.create_local_external loc ~pval_prim ~pval_type + ~local_module_name ~local_fun_name args let gen_fn_mk loc arity args : Parsetree.expression_desc = let open Parsetree in let ptyp_attributes = [] in - let local_module_name = "Tmp" in - let local_fun_name = "mk" in let pval_prim = Printf.sprintf "js_fn_mk_%02d" arity in let tyvars = (Ext_list.init (arity + 1) (fun i -> @@ -258,23 +208,17 @@ let gen_fn_mk loc arity args : Parsetree.expression_desc = (** could be optimized *) let pval_type = if arity = 0 then - arrow (arrow predef_unit_type (List.hd tyvars) ) uncurry_fn + arrow (arrow (Ast_literal.type_unit ~loc ()) (List.hd tyvars) ) uncurry_fn else arrow (Ext_list.reduce_from_right arrow tyvars) uncurry_fn in - create_local_external loc ~pval_prim ~pval_type ~pval_attributes:[] - local_module_name local_fun_name args + let local_module_name = "Tmp" in + let local_fun_name = "mk" in + Ast_comb.create_local_external loc ~pval_prim ~pval_type + ~local_module_name ~local_fun_name args -let handle_raw loc e = - create_local_external loc - ~pval_prim:prim - ~pval_type:(arrow "" predef_string_type predef_any_type) - ~pval_attributes:[] - tmp_module_name - tmp_fn - [("",e)] @@ -426,13 +370,12 @@ let handle_debugger loc payload = match payload with | Parsetree.PStr ( []) -> - create_local_external loc - ~pval_prim:prim_debugger + let predef_unit_type = Ast_literal.type_unit ~loc () in + let pval_prim = "js_debugger" in + Ast_comb.create_local_external loc + ~pval_prim ~pval_type:(arrow "" predef_unit_type predef_unit_type) - ~pval_attributes:[] - tmp_module_name - tmp_fn - [("", predef_val_unit)] + [("", Ast_literal.val_unit ~loc ())] | Parsetree.PTyp _ | Parsetree.PPat (_,_) | Parsetree.PStr _ @@ -503,7 +446,7 @@ let handle_obj_property loc obj name e (* ./dumpast -e ' (Js.Unsafe.(!) obj) # property ' *) let obj = mapper.expr mapper obj in - let down = create_local_external loc + let down = Ast_comb.create_local_external loc ~pval_prim:"js_unsafe_downgrade" ~pval_type:({ptyp_desc = Ptyp_arrow ("", @@ -519,9 +462,8 @@ let handle_obj_property loc obj name e ptyp_attributes = []}); ptyp_loc = loc; ptyp_attributes = []}) - ~pval_attributes:[] - "Tmp" - "cast" ["", obj] in + ~local_module_name:"Tmp" + ~local_fun_name:"cast" ["", obj] in { e with pexp_desc = Pexp_send ({pexp_desc = down ; @@ -566,7 +508,7 @@ let handle_obj_method loc (obj : Parsetree.expression) let len = List.length args in let obj = mapper.expr mapper obj in let args = List.map (mapper.expr mapper ) args in - let down = create_local_external loc + let down = Ast_comb.create_local_external loc ~pval_prim:"js_unsafe_downgrade" ~pval_type:({ptyp_desc = Ptyp_arrow ("", @@ -582,9 +524,8 @@ let handle_obj_method loc (obj : Parsetree.expression) ptyp_attributes = []}); ptyp_loc = loc; ptyp_attributes = []}) - ~pval_attributes:[] - "Tmp" - "cast" ["", obj] in + ~local_module_name:"Tmp" + ~local_fun_name:"cast" ["", obj] in {e with pexp_desc = gen_fn_run loc len (("", {pexp_desc = @@ -645,17 +586,21 @@ let rec unsafe_mapper : Ast_mapper.mapper = (** Begin rewriting [bs.raw], its output should not be rewritten anymore *) | Pexp_extension ( - {txt = "bs.raw"; loc} , - PStr - ( [{ pstr_desc = Pstr_eval ({ - pexp_desc = Pexp_constant (Const_string (_, _)) ; - } as e , - _); pstr_loc = _ }])) + {txt = "bs.raw"; loc} , payload) -> - {e with pexp_desc = handle_raw loc e } - | Pexp_extension({txt = "bs.raw"; loc}, (PTyp _ | PPat _ | PStr _)) - -> + begin match Ast_payload.as_string_exp payload with + | None -> Location.raise_errorf ~loc "bs.raw can only be applied to a string" + | Some exp -> + let pval_prim = "js_pure_expr" in + { exp with pexp_desc = Ast_comb.create_local_external loc + ~pval_prim + ~pval_type:(arrow "" + (Ast_literal.type_string ~loc ()) + (Ast_literal.type_any ~loc ()) ) + + ["",exp]} + end (** End rewriting [bs.raw] *) @@ -763,25 +708,18 @@ let rec unsafe_mapper : Ast_mapper.mapper = begin match str.pstr_desc with | Pstr_extension ( ({txt = "bs.raw"; loc}, payload), _attrs) -> - begin match payload with - | Parsetree.PStr - ( [{ pstr_desc = Parsetree.Pstr_eval ({ - pexp_desc = Pexp_constant (Const_string (cont, opt_label)) ; - pexp_loc; pexp_attributes } as e ,_); pstr_loc }]) + begin match Ast_payload.as_string_exp payload with + | Some exp -> Ast_helper.Str.eval - { e with pexp_desc = - create_local_external loc + { exp with pexp_desc = + Ast_comb.create_local_external loc ~pval_prim:prim_stmt ~pval_type:(arrow "" - predef_string_type predef_any_type) - ~pval_attributes:[] - tmp_module_name - tmp_fn - [("",e)]} - | Parsetree.PTyp _ - | Parsetree.PPat (_,_) - | Parsetree.PStr _ + (Ast_literal.type_string ~loc ()) + (Ast_literal.type_any ~loc ())) + ["",exp]} + | None -> Location.raise_errorf ~loc "bs.raw can only be applied to a string" end diff --git a/jscomp/syntax/syntax.mllib b/jscomp/syntax/syntax.mllib index 490613563f..fb1ba6015b 100644 --- a/jscomp/syntax/syntax.mllib +++ b/jscomp/syntax/syntax.mllib @@ -1,3 +1,5 @@ -parsetree_util +ast_lift ast_payload -ppx_entry \ No newline at end of file +ppx_entry +ast_literal +ast_comb \ No newline at end of file From 9e704c5e3b29cf3d6d1e4e7f239bfcb5eb3ed5a3 Mon Sep 17 00:00:00 2001 From: Hongbo Zhang Date: Wed, 1 Jun 2016 13:44:38 -0400 Subject: [PATCH 3/3] [refactoring] clean up --- jscomp/syntax/ast_comb.ml | 17 +++ jscomp/syntax/ast_comb.mli | 24 +++++ jscomp/syntax/ast_literal.ml | 11 ++ jscomp/syntax/ast_literal.mli | 3 +- jscomp/syntax/ast_payload.ml | 5 + jscomp/syntax/ast_payload.mli | 2 +- jscomp/syntax/ppx_entry.ml | 190 +++++++++------------------------- 7 files changed, 109 insertions(+), 143 deletions(-) diff --git a/jscomp/syntax/ast_comb.ml b/jscomp/syntax/ast_comb.ml index 6331e42a71..16ee9ee5b8 100644 --- a/jscomp/syntax/ast_comb.ml +++ b/jscomp/syntax/ast_comb.ml @@ -56,3 +56,20 @@ let create_local_external loc pexp_attributes = []; pexp_loc = loc }) + +open Ast_helper + +let exp_apply_no_label ?loc ?attrs a b = + Exp.apply ?loc ?attrs a (List.map (fun x -> "", x) b) + +let fun_no_label ?loc ?attrs pat body = + Exp.fun_ ?loc ?attrs "" None pat body + +let arrow_no_label ?loc ?attrs b c = + Typ.arrow ?loc ?attrs "" b c + +let discard_exp_as_unit loc e = + exp_apply_no_label ~loc + (Exp.ident ~loc {txt = Ast_literal.Lid.ignore_id; loc}) + [Exp.constraint_ ~loc e + (Ast_literal.type_unit ~loc ())] diff --git a/jscomp/syntax/ast_comb.mli b/jscomp/syntax/ast_comb.mli index ad85df3f06..5d973fd63e 100644 --- a/jscomp/syntax/ast_comb.mli +++ b/jscomp/syntax/ast_comb.mli @@ -29,3 +29,27 @@ val create_local_external : Location.t -> ?local_module_name:string -> ?local_fun_name:string -> (Asttypes.label * Parsetree.expression) list -> Parsetree.expression_desc + +val exp_apply_no_label : + ?loc:Location.t -> + ?attrs:Parsetree.attributes -> + Parsetree.expression -> Parsetree.expression list -> Parsetree.expression + +val fun_no_label : + ?loc:Location.t -> + ?attrs:Parsetree.attributes -> + Parsetree.pattern -> Parsetree.expression -> Parsetree.expression + +val arrow_no_label : + ?loc:Location.t -> + ?attrs:Parsetree.attributes -> + Parsetree.core_type -> Parsetree.core_type -> Parsetree.core_type + +(* note we first declare its type is [unit], + then [ignore] it, [ignore] is necessary since + the js value maybe not be of type [unit] and + we can use [unit] value (though very little chance) + sometimes +*) +val discard_exp_as_unit : + Location.t -> Parsetree.expression -> Parsetree.expression diff --git a/jscomp/syntax/ast_literal.ml b/jscomp/syntax/ast_literal.ml index b16d93145d..2e449fd8d7 100644 --- a/jscomp/syntax/ast_literal.ml +++ b/jscomp/syntax/ast_literal.ml @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Ast_helper + module Lid = struct type t = Longident.t let val_unit : t = Lident "()" @@ -47,11 +49,14 @@ module No_loc = struct Ast_helper.Typ.mk (Ptyp_constr ({ txt = Lid.type_string; loc}, [])) let type_any = Ast_helper.Typ.any () + let pat_unit = Pat.construct {txt = Lid.val_unit; loc} None end type 'a lit = ?loc: Location.t -> unit -> 'a type expression_lit = Parsetree.expression lit type core_type_lit = Parsetree.core_type lit +type pattern_lit = Parsetree.pattern lit + let val_unit ?loc () = match loc with | None -> No_loc.val_unit @@ -76,3 +81,9 @@ let type_any ?loc () = match loc with | None -> No_loc.type_any | Some loc -> Ast_helper.Typ.any ~loc () + +let pat_unit ?loc () = + match loc with + | None -> No_loc.pat_unit + | Some loc -> + Pat.construct ~loc {txt = Lid.val_unit; loc} None diff --git a/jscomp/syntax/ast_literal.mli b/jscomp/syntax/ast_literal.mli index 0ff9e378cc..4bd4c29d98 100644 --- a/jscomp/syntax/ast_literal.mli +++ b/jscomp/syntax/ast_literal.mli @@ -37,6 +37,7 @@ end type expression_lit = Parsetree.expression lit type core_type_lit = Parsetree.core_type lit +type pattern_lit = Parsetree.pattern lit val val_unit : expression_lit @@ -46,4 +47,4 @@ val type_string : core_type_lit val type_any : core_type_lit - +val pat_unit : pattern_lit diff --git a/jscomp/syntax/ast_payload.ml b/jscomp/syntax/ast_payload.ml index 33aae6800b..a25d2995fe 100644 --- a/jscomp/syntax/ast_payload.ml +++ b/jscomp/syntax/ast_payload.ml @@ -48,6 +48,11 @@ let as_string_exp (x : t ) = _}] -> Some e | _ -> None +let as_empty_structure (x : t ) = + match x with + | PStr ([]) -> true + | PTyp _ | PPat _ | PStr (_ :: _ ) -> false + let is_string_or_strings (x : t) : [ `None | `Single of string | `Some of string list ] = let module M = struct exception Not_str end in diff --git a/jscomp/syntax/ast_payload.mli b/jscomp/syntax/ast_payload.mli index 50fa5d5766..aed9b7cebd 100644 --- a/jscomp/syntax/ast_payload.mli +++ b/jscomp/syntax/ast_payload.mli @@ -31,6 +31,6 @@ type t = Parsetree.payload val is_single_string : t -> string option val as_string_exp : t -> Parsetree.expression option - +val as_empty_structure : t -> bool val is_string_or_strings : t -> [ `None | `Single of string | `Some of string list ] diff --git a/jscomp/syntax/ppx_entry.ml b/jscomp/syntax/ppx_entry.ml index 38276d8455..91b8448d0e 100644 --- a/jscomp/syntax/ppx_entry.ml +++ b/jscomp/syntax/ppx_entry.ml @@ -53,10 +53,10 @@ *) -let tmp_module_name = "J" -let tmp_fn = "unsafe_expr" -let prim_stmt = "js_pure_stmt" + + + let js_obj_type_id () = @@ -71,37 +71,9 @@ let curry_type_id () = Ast_literal.Lid.js_fn - +open Ast_helper let arrow = Ast_helper.Typ.arrow -(* note we first declare its type is [unit], - then [ignore] it, [ignore] is necessary since - the js value maybe not be of type [unit] and - we can use [unit] value (though very little chance) - sometimes -*) -let discard_js_value loc e : Parsetree.expression = - {pexp_desc = - Pexp_apply - ({pexp_desc = - Pexp_ident {txt = Ast_literal.Lid.ignore_id ; loc}; - pexp_attributes = []; - pexp_loc = loc}, - [("", - {pexp_desc = - Pexp_constraint (e, - {ptyp_desc = Ptyp_constr ({txt = Lident "unit"; loc}, []); - ptyp_loc = loc; - ptyp_attributes = []}); - pexp_loc = loc; - pexp_attributes = [] - })] - ); - pexp_loc = loc; - pexp_attributes = [] - } - - let record_as_js_object = ref None (* otherwise has an attribute *) let obj_type_as_js_obj_type = ref false let handle_record_as_js_object @@ -121,21 +93,14 @@ let handle_record_as_js_object let pval_type = let arity = List.length labels in let tyvars = (Ext_list.init arity (fun i -> - {Parsetree.ptyp_desc = Ptyp_var ("a" ^ string_of_int i); - ptyp_attributes = [] ; - ptyp_loc = loc})) in - - let result_type = - {Parsetree.ptyp_desc = - Ptyp_constr ({txt = js_obj_type_id () ; loc}, - [{ Parsetree.ptyp_desc = - Ptyp_object (List.map2 (fun x y -> x ,[], y) labels tyvars, Closed); - ptyp_attributes = []; - ptyp_loc = loc - }]); - ptyp_loc = loc; - ptyp_attributes = [] - } in + Typ.var ~loc ("a" ^ string_of_int i))) in + + let result_type = + Typ.constr ~loc {txt = js_obj_type_id () ; loc} + [ + Typ.object_ ~loc (List.map2 (fun x y -> x ,[], y) labels tyvars) Closed + ] + in List.fold_right2 (fun label tyvar acc -> arrow ~loc label tyvar acc) labels tyvars result_type in @@ -149,14 +114,10 @@ let handle_record_as_js_object args let gen_fn_run loc arity args : Parsetree.expression_desc = - let open Parsetree in - let ptyp_attributes = [] in let pval_prim = Printf.sprintf "js_fn_run_%02d" arity in let tyvars = - (Ext_list.init (arity + 1) (fun i -> - {ptyp_desc = Ptyp_var ("a" ^ string_of_int i); - ptyp_attributes ; - ptyp_loc = loc})) in + Ext_list.init (arity + 1) + (fun i -> Typ.var ~loc ("a" ^ string_of_int i)) in let tuple_type_desc = if arity = 0 then (List.hd tyvars).ptyp_desc @@ -165,13 +126,8 @@ let gen_fn_run loc arity args : Parsetree.expression_desc = Parsetree.Ptyp_tuple tyvars in let uncurry_fn = - {ptyp_desc = - Ptyp_constr ({txt = curry_type_id (); loc}, - [{ptyp_desc = tuple_type_desc ; - ptyp_attributes; - ptyp_loc = loc }]); - ptyp_attributes; - ptyp_loc = loc} in + Typ.constr ~loc {txt = curry_type_id (); loc} + [ Typ.mk ~loc tuple_type_desc] in (** could be optimized *) let pval_type = Ext_list.reduce_from_right (fun a b -> arrow ~loc "" a b) (uncurry_fn :: tyvars) in @@ -197,13 +153,9 @@ let gen_fn_mk loc arity args : Parsetree.expression_desc = Parsetree.Ptyp_tuple tyvars in let uncurry_fn = - {ptyp_desc = - Ptyp_constr ({txt = curry_type_id (); loc}, - [{ptyp_desc = tuple_type_desc ; - ptyp_attributes; - ptyp_loc = loc }]); - ptyp_attributes; - ptyp_loc = loc} in + Typ.constr ~loc {txt = curry_type_id (); loc} + [Typ.mk ~loc tuple_type_desc] + in let arrow = arrow ~loc "" in (** could be optimized *) let pval_type = @@ -217,44 +169,31 @@ let gen_fn_mk loc arity args : Parsetree.expression_desc = ~local_module_name ~local_fun_name args - - - - - - let find_uncurry_attrs_and_remove (attrs : Parsetree.attributes ) = Ext_list.exclude_with_fact (function | ({Location.txt = "uncurry"}, _) -> true | _ -> false ) attrs -let uncurry_fn_type loc ty ptyp_attributes +let uncurry_fn_type loc ty attrs (args : Parsetree.core_type ) body : Parsetree.core_type = - let open Parsetree in + let fn_type : Parsetree.core_type = match args with | {ptyp_desc = Parsetree.Ptyp_tuple [arg ; {ptyp_desc = Ptyp_constr ({txt = Lident "__"}, [])} ]; _} -> - { Parsetree.ptyp_loc = loc; - ptyp_desc = Ptyp_tuple [ arg ; body]; - ptyp_attributes} + Typ.tuple ~loc ~attrs [ arg ; body] + | {ptyp_desc = Ptyp_tuple args; _} -> - {ptyp_desc = Ptyp_tuple (List.rev (body :: List.rev args)); - ptyp_loc = loc; - ptyp_attributes - } + Typ.tuple ~loc ~attrs (List.rev (body :: List.rev args)) + | {ptyp_desc = Ptyp_constr ({txt = Lident "unit"}, []); _} -> body - | v -> {ptyp_desc = Ptyp_tuple [v ; body]; - ptyp_loc = loc ; - ptyp_attributes } + | v -> + Typ.tuple ~loc ~attrs [v ; body] in - { ty with ptyp_desc = - Ptyp_constr ({txt = curry_type_id () ; loc}, - [ fn_type]); - ptyp_attributes = [] - } + Typ.constr ~loc {txt = curry_type_id () ; loc} [ fn_type] + let uncurry_type = ref false @@ -367,20 +306,14 @@ let handle_ctyp let handle_debugger loc payload = - match payload with - | Parsetree.PStr ( []) - -> + if Ast_payload.as_empty_structure payload then let predef_unit_type = Ast_literal.type_unit ~loc () in let pval_prim = "js_debugger" in Ast_comb.create_local_external loc ~pval_prim ~pval_type:(arrow "" predef_unit_type predef_unit_type) [("", Ast_literal.val_unit ~loc ())] - | Parsetree.PTyp _ - | Parsetree.PPat (_,_) - | Parsetree.PStr _ - -> - Location.raise_errorf ~loc "bs.raw can only be applied to a string" + else Location.raise_errorf ~loc "bs.raw can only be applied to a string" (** TODO: Future {[ fun%bs this (a,b,c) -> @@ -404,22 +337,12 @@ let handle_uncurry_generation loc let body = mapper.expr mapper body in let fun_ = if len = 0 then - {Parsetree.pexp_desc = - Pexp_fun ("", None, - {ppat_desc = - Ppat_construct ({txt = Lident "()"; loc}, None); - ppat_loc = loc ; - ppat_attributes = []}, - body); - pexp_loc = loc ; - pexp_attributes = []} + Ast_comb.fun_no_label ~loc (Ast_literal.pat_unit ~loc () ) body else List.fold_right (fun arg body -> let arg = mapper.pat mapper arg in - {Parsetree. - pexp_loc = loc ; - pexp_desc = Pexp_fun ("", None, arg, body); - pexp_attributes = []}) args body in + Ast_comb.fun_no_label ~loc arg body + ) args body in {e with pexp_desc = gen_fn_mk loc len [("", fun_)]} let handle_uncurry_application loc fn (pat : Parsetree.expression) (e : Parsetree.expression) @@ -445,23 +368,17 @@ let handle_obj_property loc obj name e (mapper : Ast_mapper.mapper) : Parsetree.expression = (* ./dumpast -e ' (Js.Unsafe.(!) obj) # property ' *) let obj = mapper.expr mapper obj in - + let var = Typ.var ~loc "a" in let down = Ast_comb.create_local_external loc + ~pval_prim:"js_unsafe_downgrade" - ~pval_type:({ptyp_desc = - Ptyp_arrow ("", - {ptyp_desc = - Ptyp_constr ({txt = js_obj_type_id () ; loc}, - [{ptyp_desc = Ptyp_var "a" ; - ptyp_loc = loc; - ptyp_attributes = [] }]); - ptyp_attributes = []; - ptyp_loc = loc}, - {ptyp_desc = Ptyp_var "a"; - ptyp_loc = loc; - ptyp_attributes = []}); - ptyp_loc = loc; - ptyp_attributes = []}) + ~pval_type:( + Ast_comb.arrow_no_label ~loc + (Typ.constr ~loc + {txt = js_obj_type_id () ; loc} + [var]) + var) + ~local_module_name:"Tmp" ~local_fun_name:"cast" ["", obj] in { e with pexp_desc = @@ -508,22 +425,12 @@ let handle_obj_method loc (obj : Parsetree.expression) let len = List.length args in let obj = mapper.expr mapper obj in let args = List.map (mapper.expr mapper ) args in + let var = Typ.var ~loc "a" in let down = Ast_comb.create_local_external loc ~pval_prim:"js_unsafe_downgrade" - ~pval_type:({ptyp_desc = - Ptyp_arrow ("", - {ptyp_desc = - Ptyp_constr ({txt = js_obj_type_id () ; loc}, - [{ptyp_desc = Ptyp_var "a" ; - ptyp_loc = loc; - ptyp_attributes = [] }]); - ptyp_attributes = []; - ptyp_loc = loc}, - {ptyp_desc = Ptyp_var "a"; - ptyp_loc = loc; - ptyp_attributes = []}); - ptyp_loc = loc; - ptyp_attributes = []}) + ~pval_type:(Ast_comb.arrow_no_label ~loc + (Typ.constr ~loc {txt = js_obj_type_id () ; loc} [var]) + var ) ~local_module_name:"Tmp" ~local_fun_name:"cast" ["", obj] in {e with pexp_desc = gen_fn_run loc len @@ -711,10 +618,11 @@ let rec unsafe_mapper : Ast_mapper.mapper = begin match Ast_payload.as_string_exp payload with | Some exp -> + let pval_prim = "js_pure_stmt" in Ast_helper.Str.eval { exp with pexp_desc = Ast_comb.create_local_external loc - ~pval_prim:prim_stmt + ~pval_prim ~pval_type:(arrow "" (Ast_literal.type_string ~loc ()) (Ast_literal.type_any ~loc ()))