,\n\
};\n\
- ") ;
- File ("Index.re",
- "ReactDOMRe.renderToElementWithId(, \"index\");\n\
- ") ;
- File ("index.html",
- "\n\
- \n\
- \n\
- \ \n\
- \ Pure Reason Example\n\
- \n\
- \n\
- \ \n\
- \ \n\
- \n\
- \n\
")]) ;
File ("README.md",
"# ${bsb:name}\n\
\n\
- Run this project:\n\
+ ## Run Project\n\
\n\
- ```\n\
+ ```sh\n\
npm install\n\
npm start\n\
# in another tab\n\
npm run webpack\n\
```\n\
- \n\
- After you see the webpack compilation succeed (the `npm run webpack` step), open up the nested html files in `src/*` (**no server needed!**). Then modify whichever file in `src` and refresh the page to see the changes.\n\
+ After you see the webpack compilation succeed (the `npm run webpack` step), open up `src/index.html` (**no server needed!**). Then modify whichever `.re` file in `src` and refresh the page to see the changes.\n\
\n\
**For more elaborate ReasonReact examples**, please see https://github.com/reasonml-community/reason-react-example\n\
+ \n\
+ ## Build for Production\n\
+ \n\
+ ```sh\n\
+ npm run build\n\
+ npm run webpack:production\n\
+ ```\n\
+ \n\
+ This will replace the development artifact `build/Index.js` for an optimized version.\n\
") ;
File ("package.json",
"{\n\
@@ -552,7 +620,8 @@ let root = OCamlRes.Res.([
\ \"start\": \"bsb -make-world -w\",\n\
\ \"clean\": \"bsb -clean-world\",\n\
\ \"test\": \"echo \\\"Error: no test specified\\\" && exit 1\",\n\
- \ \"webpack\": \"webpack -w\"\n\
+ \ \"webpack\": \"webpack -w\",\n\
+ \ \"webpack:production\": \"NODE_ENV=production webpack\"\n\
\ },\n\
\ \"keywords\": [\n\
\ \"BuckleScript\"\n\
@@ -560,13 +629,14 @@ let root = OCamlRes.Res.([
\ \"author\": \"\",\n\
\ \"license\": \"MIT\",\n\
\ \"dependencies\": {\n\
- \ \"react\": \"^15.4.2\",\n\
- \ \"react-dom\": \"^15.4.2\",\n\
- \ \"reason-react\": \">=0.3.0\"\n\
+ \ \"react\": \"^16.2.0\",\n\
+ \ \"react-dom\": \"^16.2.0\",\n\
+ \ \"reason-react\": \">=0.3.4\"\n\
\ },\n\
\ \"devDependencies\": {\n\
\ \"bs-platform\": \"^${bsb:bs-version}\",\n\
- \ \"webpack\": \"^3.8.1\"\n\
+ \ \"webpack\": \"^4.0.1\",\n\
+ \ \"webpack-cli\": \"^2.0.10\"\n\
\ }\n\
}\n\
") ;
@@ -585,7 +655,7 @@ let root = OCamlRes.Res.([
\ \"subdirs\" : true\n\
\ },\n\
\ \"package-specs\": [{\n\
- \ \"module\": \"commonjs\",\n\
+ \ \"module\": \"es6\",\n\
\ \"in-source\": true\n\
\ }],\n\
\ \"suffix\": \".bs.js\",\n\
diff --git a/jscomp/syntax/ast_core_type_class_type.ml b/jscomp/syntax/ast_core_type_class_type.ml
new file mode 100644
index 0000000000..9b38f37e7e
--- /dev/null
+++ b/jscomp/syntax/ast_core_type_class_type.ml
@@ -0,0 +1,217 @@
+(* Copyright (C) 2018 Authors of BuckleScript
+ *
+ * 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. *)
+open Ast_helper
+let process_getter_setter ~no ~get ~set
+ loc name
+ (attrs : Ast_attributes.t)
+ (ty : Parsetree.core_type) acc =
+ match Ast_attributes.process_method_attributes_rev attrs with
+ | {get = None; set = None}, _ -> no ty :: acc
+ | st , pctf_attributes
+ ->
+ let get_acc =
+ match st.set with
+ | Some `No_get -> acc
+ | None
+ | Some `Get ->
+ let lift txt =
+ Typ.constr ~loc {txt ; loc} [ty] in
+ let (null,undefined) =
+ match st with
+ | {get = Some (null, undefined) } -> (null, undefined)
+ | {get = None} -> (false, false ) in
+ let ty =
+ match (null,undefined) with
+ | false, false -> ty
+ | true, false -> lift Ast_literal.Lid.js_null
+ | false, true -> lift Ast_literal.Lid.js_undefined
+ | true , true -> lift Ast_literal.Lid.js_null_undefined in
+ get ty name pctf_attributes
+ :: acc
+ in
+ if st.set = None then get_acc
+ else
+ set ty (name ^ Literals.setter_suffix) pctf_attributes
+ :: get_acc
+
+
+let handle_class_type_field self
+ ({pctf_loc = loc } as ctf : Parsetree.class_type_field)
+ acc =
+ match ctf.pctf_desc with
+ | Pctf_method
+ (name, private_flag, virtual_flag, ty)
+ ->
+ let no (ty : Parsetree.core_type) =
+ let ty =
+ match ty.ptyp_desc with
+ | Ptyp_arrow (label, args, body)
+ ->
+ Ast_util.to_method_type
+ ty.ptyp_loc self label args body
+
+ | Ptyp_poly (strs, {ptyp_desc = Ptyp_arrow (label, args, body);
+ ptyp_loc})
+ ->
+ {ty with ptyp_desc =
+ Ptyp_poly(strs,
+ Ast_util.to_method_type
+ ptyp_loc self label args body )}
+ | _ ->
+ self.typ self ty
+ in
+ {ctf with
+ pctf_desc =
+ Pctf_method (name , private_flag, virtual_flag, ty)}
+ in
+ let get ty name pctf_attributes =
+ {ctf with
+ pctf_desc =
+ Pctf_method (name ,
+ private_flag,
+ virtual_flag,
+ self.typ self ty
+ );
+ pctf_attributes} in
+ let set ty name pctf_attributes =
+ {ctf with
+ pctf_desc =
+ Pctf_method (name,
+ private_flag,
+ virtual_flag,
+ Ast_util.to_method_type
+ loc self "" ty
+ (Ast_literal.type_unit ~loc ())
+ );
+ pctf_attributes} in
+ process_getter_setter ~no ~get ~set loc name ctf.pctf_attributes ty acc
+
+ | Pctf_inherit _
+ | Pctf_val _
+ | Pctf_constraint _
+ | Pctf_attribute _
+ | Pctf_extension _ ->
+ Bs_ast_mapper.default_mapper.class_type_field self ctf :: acc
+
+
+(*
+ Attributes are very hard to attribute
+ (since ptyp_attributes could happen in so many places),
+ and write ppx extensions correctly,
+ we can only use it locally
+*)
+
+let handle_core_type
+ ~(super : Bs_ast_mapper.mapper)
+ ~(self : Bs_ast_mapper.mapper)
+ (ty : Parsetree.core_type)
+ record_as_js_object
+ =
+ match ty with
+ | {ptyp_desc = Ptyp_extension({txt = ("bs.obj"|"obj")}, PTyp ty)}
+ ->
+ Ext_ref.non_exn_protect record_as_js_object true
+ (fun _ -> self.typ self ty )
+ | {ptyp_attributes ;
+ ptyp_desc = Ptyp_arrow (label, args, body);
+ (* let it go without regard label names,
+ it will report error later when the label is not empty
+ *)
+ ptyp_loc = loc
+ } ->
+ begin match Ast_attributes.process_attributes_rev ptyp_attributes with
+ | `Uncurry , ptyp_attributes ->
+ Ast_util.to_uncurry_type loc self label args body
+ | `Meth_callback, ptyp_attributes ->
+ Ast_util.to_method_callback_type loc self label args body
+ | `Method, ptyp_attributes ->
+ Ast_util.to_method_type loc self label args body
+ | `Nothing , _ ->
+ Bs_ast_mapper.default_mapper.typ self ty
+ end
+ | {
+ ptyp_desc = Ptyp_object ( methods, closed_flag) ;
+ ptyp_loc = loc
+ } ->
+ let (+>) attr (typ : Parsetree.core_type) =
+ {typ with ptyp_attributes = attr :: typ.ptyp_attributes} in
+ let new_methods =
+ Ext_list.fold_right (fun (label, ptyp_attrs, core_type) acc ->
+ let get ty name attrs =
+ let attrs, core_type =
+ match Ast_attributes.process_attributes_rev attrs with
+ | `Nothing, attrs -> attrs, ty (* #1678 *)
+ | `Uncurry, attrs ->
+ attrs, Ast_attributes.bs +> ty
+ | `Method, _
+ -> Location.raise_errorf ~loc "bs.get/set conflicts with bs.meth"
+ | `Meth_callback, attrs ->
+ attrs, Ast_attributes.bs_this +> ty
+ in
+ name , attrs, self.typ self core_type in
+ let set ty name attrs =
+ let attrs, core_type =
+ match Ast_attributes.process_attributes_rev attrs with
+ | `Nothing, attrs -> attrs, ty
+ | `Uncurry, attrs ->
+ attrs, Ast_attributes.bs +> ty
+ | `Method, _
+ -> Location.raise_errorf ~loc "bs.get/set conflicts with bs.meth"
+ | `Meth_callback, attrs ->
+ attrs, Ast_attributes.bs_this +> ty
+ in
+ name, attrs, Ast_util.to_method_type loc self "" core_type
+ (Ast_literal.type_unit ~loc ()) in
+ let no ty =
+ let attrs, core_type =
+ match Ast_attributes.process_attributes_rev ptyp_attrs with
+ | `Nothing, attrs -> attrs, ty
+ | `Uncurry, attrs ->
+ attrs, Ast_attributes.bs +> ty
+ | `Method, attrs ->
+ attrs, Ast_attributes.bs_method +> ty
+ | `Meth_callback, attrs ->
+ attrs, Ast_attributes.bs_this +> ty in
+ label, attrs, self.typ self core_type in
+ process_getter_setter ~no ~get ~set
+ loc label ptyp_attrs core_type acc
+ ) methods [] in
+ let inner_type =
+ { ty
+ with ptyp_desc = Ptyp_object(new_methods, closed_flag);
+ } in
+ if !record_as_js_object then
+ Ast_comb.to_js_type loc inner_type
+ else inner_type
+ | _ -> super.typ self ty
+
+let handle_class_type_fields self fields =
+ Ext_list.fold_right
+ (handle_class_type_field self)
+ fields []
+
+let handle_core_type self typ record_as_js_object =
+ handle_core_type
+ ~super:Bs_ast_mapper.default_mapper
+ ~self typ record_as_js_object
\ No newline at end of file
diff --git a/jscomp/syntax/ast_core_type_class_type.mli b/jscomp/syntax/ast_core_type_class_type.mli
new file mode 100644
index 0000000000..6b466944cf
--- /dev/null
+++ b/jscomp/syntax/ast_core_type_class_type.mli
@@ -0,0 +1,36 @@
+(* Copyright (C) 2018 Authors of BuckleScript
+ *
+ * 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 handle_class_type_fields :
+ Bs_ast_mapper.mapper ->
+ Parsetree.class_type_field list ->
+ Parsetree.class_type_field list
+
+val handle_core_type :
+ Bs_ast_mapper.mapper ->
+ Parsetree.core_type ->
+ bool ref ->
+ Parsetree.core_type
\ No newline at end of file
diff --git a/jscomp/syntax/ast_exp_apply.ml b/jscomp/syntax/ast_exp_apply.ml
new file mode 100644
index 0000000000..852cb9a635
--- /dev/null
+++ b/jscomp/syntax/ast_exp_apply.ml
@@ -0,0 +1,129 @@
+(* Copyright (C) 2018 Authors of BuckleScript
+ *
+ * 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. *)
+
+open Ast_helper
+
+let handle_exp_apply
+ (e : Parsetree.expression)
+ (self : Bs_ast_mapper.mapper)
+ (fn : Parsetree.expression)
+ (args : (Asttypes.label * Parsetree.expression) list)
+ =
+ let loc = e.pexp_loc in
+ begin match fn with
+ | {pexp_desc =
+ Pexp_apply (
+ {pexp_desc =
+ Pexp_ident {txt = Lident "##" ; loc} ; _},
+ [("", obj) ;
+ ("", {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _} )
+ ]);
+ _} -> (* f##paint 1 2 *)
+ {e with pexp_desc = Ast_util.method_apply loc self obj name args }
+ | {pexp_desc =
+ Pexp_apply (
+ {pexp_desc =
+ Pexp_ident {txt = Lident "#@" ; loc} ; _},
+ [("", obj) ;
+ ("", {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _} )
+ ]);
+ _} -> (* f##paint 1 2 *)
+ {e with pexp_desc = Ast_util.property_apply loc self obj name args }
+
+ | {pexp_desc =
+ Pexp_ident {txt = Lident "##" ; loc} ; _}
+ ->
+ begin match args with
+ | [("", obj) ;
+ ("", {pexp_desc = Pexp_apply(
+ {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _},
+ args
+ ); pexp_attributes = attrs }
+ (* we should warn when we discard attributes *)
+ )
+ ] -> (* f##(paint 1 2 ) *)
+ (* gpr#1063 foo##(bar##baz) we should rewrite (bar##baz)
+ first before pattern match.
+ currently the pattern match is written in a top down style.
+ Another corner case: f##(g a b [@bs])
+ *)
+ Bs_ast_invariant.warn_unused_attributes attrs ;
+ {e with pexp_desc = Ast_util.method_apply loc self obj name args}
+ | [("", obj) ;
+ ("",
+ {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _}
+ ) (* f##paint *)
+ ] ->
+ { e with pexp_desc =
+ Ast_util.js_property loc (self.expr self obj) name
+ }
+
+ | _ ->
+ Location.raise_errorf ~loc
+ "Js object ## expect syntax like obj##(paint (a,b)) "
+ end
+ (* we can not use [:=] for precedece cases
+ like {[i @@ x##length := 3 ]}
+ is parsed as {[ (i @@ x##length) := 3]}
+ since we allow user to create Js objects in OCaml, it can be of
+ ref type
+ {[
+ let u = object (self)
+ val x = ref 3
+ method setX x = self##x := 32
+ method getX () = !self##x
+ end
+ ]}
+ *)
+ | {pexp_desc =
+ Pexp_ident {txt = Lident ("#=" )}
+ } ->
+ begin match args with
+ | ["",
+ {pexp_desc =
+ Pexp_apply ({pexp_desc = Pexp_ident {txt = Lident "##"}},
+ ["", obj;
+ "", {pexp_desc = Pexp_ident {txt = Lident name}}
+ ]
+ )};
+ "", arg
+ ] ->
+ Exp.constraint_ ~loc
+ { e with
+ pexp_desc =
+ Ast_util.method_apply loc self obj
+ (name ^ Literals.setter_suffix) ["", arg ] }
+ (Ast_literal.type_unit ~loc ())
+ | _ -> Bs_ast_mapper.default_mapper.expr self e
+ end
+ | _ ->
+ begin match
+ Ext_list.exclude_with_val
+ Ast_attributes.is_bs e.pexp_attributes with
+ | false, _ -> Bs_ast_mapper.default_mapper.expr self e
+ | true, pexp_attributes ->
+ {e with pexp_desc = Ast_util.uncurry_fn_apply loc self fn args ;
+ pexp_attributes }
+ end
+ end
diff --git a/jscomp/syntax/ast_exp_apply.mli b/jscomp/syntax/ast_exp_apply.mli
new file mode 100644
index 0000000000..2484101db5
--- /dev/null
+++ b/jscomp/syntax/ast_exp_apply.mli
@@ -0,0 +1,31 @@
+(* Copyright (C) 2018 Authors of BuckleScript
+ *
+ * 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 handle_exp_apply :
+ Parsetree.expression ->
+ Bs_ast_mapper.mapper ->
+ Parsetree.expression ->
+ (Asttypes.label * Parsetree.expression) list ->
+ Parsetree.expression
diff --git a/jscomp/syntax/ast_exp_extension.ml b/jscomp/syntax/ast_exp_extension.ml
new file mode 100644
index 0000000000..b30563b7bd
--- /dev/null
+++ b/jscomp/syntax/ast_exp_extension.ml
@@ -0,0 +1,207 @@
+(* Copyright (C) 2018 Authors of BuckleScript
+ *
+ * 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. *)
+open Ast_helper
+
+let handle_extension record_as_js_object e (self : Bs_ast_mapper.mapper)
+ (({txt ; loc} as lid , payload) : Parsetree.extension) =
+ begin match txt with
+ | "bs.raw" | "raw" ->
+ Ast_util.handle_raw loc payload
+ | "bs.re" | "re" ->
+ Exp.constraint_ ~loc
+ (Ast_util.handle_raw ~check_js_regex:true loc payload)
+ (Ast_comb.to_js_re_type loc)
+ | "bs.external" | "external" ->
+ begin match Ast_payload.as_ident payload with
+ | Some {txt = Lident x}
+ -> Ast_util.handle_external loc x
+ (* do we need support [%external gg.xx ]
+
+ {[ Js.Undefined.to_opt (if Js.typeof x == "undefined" then x else Js.Undefined.empty ) ]}
+ *)
+
+ | None | Some _ ->
+ Location.raise_errorf ~loc
+ "external expects a single identifier"
+ end
+ | "bs.time"| "time" ->
+ (
+ match payload with
+ | PStr [{pstr_desc = Pstr_eval (e,_)}] ->
+ let locString =
+ if loc.loc_ghost then
+ "GHOST LOC"
+ else
+ let loc_start = loc.loc_start in
+ let (file, lnum, __) = Location.get_pos_info loc_start in
+ Printf.sprintf "%s %d"
+ file lnum in
+ let e = self.expr self e in
+ Exp.sequence ~loc
+ (Exp.apply ~loc
+ (Exp.ident ~loc {loc;
+ txt =
+ Ldot (Ldot (Lident "Js", "Console"), "timeStart")
+ })
+ ["", Exp.constant ~loc (Const_string (locString,None))]
+ )
+ ( Exp.let_ ~loc Nonrecursive
+ [Vb.mk ~loc (Pat.var ~loc {loc; txt = "timed"}) e ;
+ ]
+ (Exp.sequence ~loc
+ (Exp.apply ~loc
+ (Exp.ident ~loc {loc;
+ txt =
+ Ldot (Ldot (Lident "Js", "Console"), "timeEnd")
+ })
+ ["", Exp.constant ~loc (Const_string (locString,None))]
+ )
+ (Exp.ident ~loc {loc; txt = Lident "timed"})
+ )
+ )
+ | _ ->
+ Location.raise_errorf
+ ~loc "expect a boolean expression in the payload"
+ )
+ | "bs.assert" | "assert" ->
+ (
+ match payload with
+ | PStr [ {pstr_desc = Pstr_eval( e,_)}] ->
+
+ let locString =
+ if loc.loc_ghost then
+ "ASSERT FAILURE"
+ else
+ let loc_start = loc.loc_start in
+ let (file, lnum, cnum) = Location.get_pos_info loc_start in
+ let enum =
+ loc.Location.loc_end.Lexing.pos_cnum -
+ loc_start.Lexing.pos_cnum + cnum in
+ Printf.sprintf "File %S, line %d, characters %d-%d"
+ file lnum cnum enum in
+ let raiseWithString locString =
+ (Exp.apply ~loc
+ (Exp.ident ~loc {loc; txt =
+ Ldot(Ldot (Lident "Js","Exn"),"raiseError")})
+ ["",
+
+ Exp.constant (Const_string (locString,None))
+ ])
+ in
+ (match e.pexp_desc with
+ | Pexp_construct({txt = Lident "false"},None) ->
+ (* The backend will convert [assert false] into a nop later *)
+ if !Clflags.no_assert_false then
+ Exp.assert_ ~loc
+ (Exp.construct ~loc {txt = Lident "false";loc} None)
+ else
+ (raiseWithString locString)
+ | Pexp_constant (Const_string (r, _)) ->
+ if !Clflags.noassert then
+ Exp.assert_ ~loc (Exp.construct ~loc {txt = Lident "true"; loc} None)
+ (* Need special handling to make it type check*)
+ else
+ raiseWithString r
+ | _ ->
+ let e = self.expr self e in
+ if !Clflags.noassert then
+ (* pass down so that it still type check, but the backend will
+ make it a nop
+ *)
+ Exp.assert_ ~loc e
+ else
+ Exp.ifthenelse ~loc
+ (Exp.apply ~loc
+ (Exp.ident {loc ; txt = Ldot(Lident "Pervasives","not")})
+ ["", e]
+ )
+ (raiseWithString locString)
+ None
+ )
+ | _ ->
+ Location.raise_errorf
+ ~loc "expect a boolean expression in the payload"
+ )
+ | "bs.node" | "node" ->
+ let strip s =
+ match s with
+ | "_module" -> "module"
+ | x -> x in
+ begin match Ast_payload.as_ident payload with
+ | Some {txt = Lident
+ ( "__filename"
+ | "__dirname"
+ | "_module"
+ | "require" as name); loc}
+ ->
+ let exp =
+ Ast_util.handle_external loc (strip name) in
+ let typ =
+ Ast_core_type.lift_option_type
+ @@
+ if name = "_module" then
+ Typ.constr ~loc
+ { txt = Ldot (Lident "Node", "node_module") ;
+ loc} []
+ else if name = "require" then
+ (Typ.constr ~loc
+ { txt = Ldot (Lident "Node", "node_require") ;
+ loc} [] )
+ else
+ Ast_literal.type_string ~loc () in
+ Exp.constraint_ ~loc exp typ
+ | Some _ | None ->
+ begin match payload with
+ | PTyp _ ->
+ Location.raise_errorf
+ ~loc "Illegal payload, expect an expression payload instead of type payload"
+ | PPat _ ->
+ Location.raise_errorf
+ ~loc "Illegal payload, expect an expression payload instead of pattern payload"
+ | _ ->
+ Location.raise_errorf
+ ~loc "Illegal payload"
+ end
+
+ end
+ | "bs.debugger"|"debugger" ->
+ {e with pexp_desc = Ast_util.handle_debugger loc payload}
+ | "bs.obj" | "obj" ->
+ begin match payload with
+ | PStr [{pstr_desc = Pstr_eval (e,_)}]
+ ->
+ Ext_ref.non_exn_protect record_as_js_object true
+ (fun () -> self.expr self e )
+ | _ -> Location.raise_errorf ~loc "Expect an expression here"
+ end
+ | _ ->
+ match payload with
+ | PTyp typ when Ext_string.starts_with txt Literals.bs_deriving_dot ->
+ self.expr self (Ast_derive.gen_expression lid typ)
+ | _ ->
+ e (* For an unknown extension, we don't really need to process further*)
+ (* Exp.extension ~loc ~attrs:e.pexp_attributes (
+ self.extension self extension) *)
+ (* Bs_ast_mapper.default_mapper.expr self e *)
+ end
diff --git a/jscomp/syntax/ast_exp_extension.mli b/jscomp/syntax/ast_exp_extension.mli
new file mode 100644
index 0000000000..1a8229ad45
--- /dev/null
+++ b/jscomp/syntax/ast_exp_extension.mli
@@ -0,0 +1,31 @@
+(* Copyright (C) 2018 Authors of BuckleScript
+ *
+ * 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 handle_extension :
+ bool ref ->
+ Parsetree.expression ->
+ Bs_ast_mapper.mapper ->
+ Parsetree.extension ->
+ Parsetree.expression
diff --git a/jscomp/syntax/ast_tuple_pattern_flatten.ml b/jscomp/syntax/ast_tuple_pattern_flatten.ml
new file mode 100644
index 0000000000..f912ee20b4
--- /dev/null
+++ b/jscomp/syntax/ast_tuple_pattern_flatten.ml
@@ -0,0 +1,106 @@
+(* Copyright (C) 2018 Authors of BuckleScript
+ *
+ * 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 loc = Location.t
+
+ type acc =
+ (Asttypes.override_flag * Longident.t Asttypes.loc * loc *
+ Parsetree.attributes) list
+
+let rec is_simple_pattern (p : Parsetree.pattern) =
+ match p.ppat_desc with
+ | Ppat_any -> true
+ | Ppat_var _ -> true
+ | Ppat_constraint(p,_) -> is_simple_pattern p
+ | _ -> false
+
+(**
+ destruct such pattern
+ {[ A.B.let open C in (a,b)]}
+*)
+let rec destruct_open
+ (e : Parsetree.expression) (acc : acc)
+ : (acc * Parsetree.expression list) option =
+ match e.pexp_desc with
+ | Pexp_open (flag, lid, cont)
+ ->
+ destruct_open
+ cont
+ ((flag, lid, e.pexp_loc, e.pexp_attributes) :: acc)
+ | Pexp_tuple es -> Some (acc, es)
+ | _ -> None
+
+
+(*
+ [let (a,b) = M.N.(c,d) ]
+ =>
+ [ let a = M.N.c
+ and b = M.N.d ]
+*)
+let flattern_tuple_pattern_vb
+ (self : Bs_ast_mapper.mapper)
+ ({pvb_loc } as vb : Parsetree.value_binding)
+ acc : Parsetree.value_binding list =
+ let pvb_pat = self.pat self vb.pvb_pat in
+ let pvb_expr = self.expr self vb.pvb_expr in
+ let pvb_attributes = self.attributes self vb.pvb_attributes in
+ match destruct_open pvb_expr [] , pvb_pat.ppat_desc with
+ | Some (wholes, es), Ppat_tuple xs
+ when
+ List.for_all is_simple_pattern xs &&
+ Ext_list.same_length es xs
+ ->
+ (Ext_list.fold_right2 (fun pat exp acc->
+ {Parsetree.
+ pvb_pat =
+ pat;
+ pvb_expr =
+ ( match wholes with
+ | [] -> exp
+ | _ ->
+ List.fold_left (fun x (flag,lid,loc,attrs) ->
+ {Parsetree.
+ pexp_desc = Pexp_open(flag,lid,x);
+ pexp_attributes = attrs;
+ pexp_loc = loc
+ }
+ ) exp wholes) ;
+ pvb_attributes;
+ pvb_loc ;
+ } :: acc
+ ) xs es) acc
+ | _ ->
+ {pvb_pat ;
+ pvb_expr ;
+ pvb_loc ;
+ pvb_attributes} :: acc
+
+
+
+let handle_value_bindings =
+ fun self (vbs : Parsetree.value_binding list) ->
+ (* Bs_ast_mapper.default_mapper.value_bindings self vbs *)
+ List.fold_right (fun vb acc ->
+ flattern_tuple_pattern_vb self vb acc
+ ) vbs []
\ No newline at end of file
diff --git a/jscomp/syntax/ast_tuple_pattern_flatten.mli b/jscomp/syntax/ast_tuple_pattern_flatten.mli
new file mode 100644
index 0000000000..d86d2ed01b
--- /dev/null
+++ b/jscomp/syntax/ast_tuple_pattern_flatten.mli
@@ -0,0 +1,30 @@
+(* Copyright (C) 2018 Authors of BuckleScript
+ *
+ * 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 handle_value_bindings :
+ Bs_ast_mapper.mapper ->
+ Parsetree.value_binding list ->
+ Parsetree.value_binding list
\ No newline at end of file
diff --git a/jscomp/syntax/ppx_entry.ml b/jscomp/syntax/ppx_entry.ml
index 9d5b022a31..4bceee2dd3 100644
--- a/jscomp/syntax/ppx_entry.ml
+++ b/jscomp/syntax/ppx_entry.ml
@@ -70,25 +70,11 @@ let reset () =
record_as_js_object := false ;
no_export := false
-let rec is_simple_pattern (p : Parsetree.pattern) =
- match p.ppat_desc with
- | Ppat_any -> true
- | Ppat_var _ -> true
- | Ppat_constraint(p,_) -> is_simple_pattern p
- | _ -> false
-
-let rec destruct
- acc (e : Parsetree.expression) =
- match e.pexp_desc with
- | Pexp_open (flag, lid, cont)
- ->
- destruct
- ((flag, lid, e.pexp_loc, e.pexp_attributes) :: acc)
- cont
- | Pexp_tuple es -> Some (acc, es)
- | _ -> None
-
-let newTdcls tdcls newAttrs =
+
+
+let newTdcls
+ (tdcls : Parsetree.type_declaration list)
+ (newAttrs : Parsetree.attributes) : Parsetree.type_declaration list =
match tdcls with
| [ x ] ->
[{ x with Parsetree.ptype_attributes = newAttrs}]
@@ -97,411 +83,17 @@ let newTdcls tdcls newAttrs =
(fun last x ->
if last then { x with Parsetree.ptype_attributes = newAttrs} else x )
tdcls
-(*
- [let (a,b) = M.N.(c,d) ]
- =>
- [ let a = M.N.c
- and b = M.N.d ]
-*)
-let flattern_tuple_pattern_vb
- (self : Bs_ast_mapper.mapper)
- ({pvb_loc } as vb : Parsetree.value_binding)
- acc : Parsetree.value_binding list =
- let pvb_pat = self.pat self vb.pvb_pat in
- let pvb_expr = self.expr self vb.pvb_expr in
- let pvb_attributes = self.attributes self vb.pvb_attributes in
- match destruct [] pvb_expr, pvb_pat.ppat_desc with
- | Some (wholes, es), Ppat_tuple xs
- when
- List.for_all is_simple_pattern xs &&
- Ext_list.same_length es xs
- ->
- (Ext_list.fold_right2 (fun pat exp acc->
- {Parsetree.
- pvb_pat =
- pat;
- pvb_expr =
- ( match wholes with
- | [] -> exp
- | _ ->
- List.fold_left (fun x (flag,lid,loc,attrs) ->
- {Parsetree.
- pexp_desc = Pexp_open(flag,lid,x);
- pexp_attributes = attrs;
- pexp_loc = loc
- }
- ) exp wholes) ;
- pvb_attributes;
- pvb_loc ;
- } :: acc
- ) xs es) acc
- | _ ->
- {pvb_pat ;
- pvb_expr ;
- pvb_loc ;
- pvb_attributes} :: acc
-
-
-
-let process_getter_setter ~no ~get ~set
- loc name
- (attrs : Ast_attributes.t)
- (ty : Parsetree.core_type) acc =
- match Ast_attributes.process_method_attributes_rev attrs with
- | {get = None; set = None}, _ -> no ty :: acc
- | st , pctf_attributes
- ->
- let get_acc =
- match st.set with
- | Some `No_get -> acc
- | None
- | Some `Get ->
- let lift txt =
- Typ.constr ~loc {txt ; loc} [ty] in
- let (null,undefined) =
- match st with
- | {get = Some (null, undefined) } -> (null, undefined)
- | {get = None} -> (false, false ) in
- let ty =
- match (null,undefined) with
- | false, false -> ty
- | true, false -> lift Ast_literal.Lid.js_null
- | false, true -> lift Ast_literal.Lid.js_undefined
- | true , true -> lift Ast_literal.Lid.js_null_undefined in
- get ty name pctf_attributes
- :: acc
- in
- if st.set = None then get_acc
- else
- set ty (name ^ Literals.setter_suffix) pctf_attributes
- :: get_acc
-
-
-
-let handle_class_type_field self
- ({pctf_loc = loc } as ctf : Parsetree.class_type_field)
- acc =
- match ctf.pctf_desc with
- | Pctf_method
- (name, private_flag, virtual_flag, ty)
- ->
- let no (ty : Parsetree.core_type) =
- let ty =
- match ty.ptyp_desc with
- | Ptyp_arrow (label, args, body)
- ->
- Ast_util.to_method_type
- ty.ptyp_loc self label args body
- | Ptyp_poly (strs, {ptyp_desc = Ptyp_arrow (label, args, body);
- ptyp_loc})
- ->
- {ty with ptyp_desc =
- Ptyp_poly(strs,
- Ast_util.to_method_type
- ptyp_loc self label args body )}
- | _ ->
- self.typ self ty
- in
- {ctf with
- pctf_desc =
- Pctf_method (name , private_flag, virtual_flag, ty)}
- in
- let get ty name pctf_attributes =
- {ctf with
- pctf_desc =
- Pctf_method (name ,
- private_flag,
- virtual_flag,
- self.typ self ty
- );
- pctf_attributes} in
- let set ty name pctf_attributes =
- {ctf with
- pctf_desc =
- Pctf_method (name,
- private_flag,
- virtual_flag,
- Ast_util.to_method_type
- loc self "" ty
- (Ast_literal.type_unit ~loc ())
- );
- pctf_attributes} in
- process_getter_setter ~no ~get ~set loc name ctf.pctf_attributes ty acc
-
- | Pctf_inherit _
- | Pctf_val _
- | Pctf_constraint _
- | Pctf_attribute _
- | Pctf_extension _ ->
- Bs_ast_mapper.default_mapper.class_type_field self ctf :: acc
-
-(*
- Attributes are very hard to attribute
- (since ptyp_attributes could happen in so many places),
- and write ppx extensions correctly,
- we can only use it locally
-*)
-let handle_core_type
- (super : Bs_ast_mapper.mapper)
- (self : Bs_ast_mapper.mapper)
- (ty : Parsetree.core_type) =
- match ty with
- | {ptyp_desc = Ptyp_extension({txt = ("bs.obj"|"obj")}, PTyp ty)}
- ->
- Ext_ref.non_exn_protect record_as_js_object true
- (fun _ -> self.typ self ty )
- | {ptyp_attributes ;
- ptyp_desc = Ptyp_arrow (label, args, body);
- (* let it go without regard label names,
- it will report error later when the label is not empty
- *)
- ptyp_loc = loc
- } ->
- begin match Ast_attributes.process_attributes_rev ptyp_attributes with
- | `Uncurry , ptyp_attributes ->
- Ast_util.to_uncurry_type loc self label args body
- | `Meth_callback, ptyp_attributes ->
- Ast_util.to_method_callback_type loc self label args body
- | `Method, ptyp_attributes ->
- Ast_util.to_method_type loc self label args body
- | `Nothing , _ ->
- Bs_ast_mapper.default_mapper.typ self ty
- end
- | {
- ptyp_desc = Ptyp_object ( methods, closed_flag) ;
- ptyp_loc = loc
- } ->
- let (+>) attr (typ : Parsetree.core_type) =
- {typ with ptyp_attributes = attr :: typ.ptyp_attributes} in
- let new_methods =
- Ext_list.fold_right (fun (label, ptyp_attrs, core_type) acc ->
- let get ty name attrs =
- let attrs, core_type =
- match Ast_attributes.process_attributes_rev attrs with
- | `Nothing, attrs -> attrs, ty (* #1678 *)
- | `Uncurry, attrs ->
- attrs, Ast_attributes.bs +> ty
- | `Method, _
- -> Location.raise_errorf ~loc "bs.get/set conflicts with bs.meth"
- | `Meth_callback, attrs ->
- attrs, Ast_attributes.bs_this +> ty
- in
- name , attrs, self.typ self core_type in
- let set ty name attrs =
- let attrs, core_type =
- match Ast_attributes.process_attributes_rev attrs with
- | `Nothing, attrs -> attrs, ty
- | `Uncurry, attrs ->
- attrs, Ast_attributes.bs +> ty
- | `Method, _
- -> Location.raise_errorf ~loc "bs.get/set conflicts with bs.meth"
- | `Meth_callback, attrs ->
- attrs, Ast_attributes.bs_this +> ty
- in
- name, attrs, Ast_util.to_method_type loc self "" core_type
- (Ast_literal.type_unit ~loc ()) in
- let no ty =
- let attrs, core_type =
- match Ast_attributes.process_attributes_rev ptyp_attrs with
- | `Nothing, attrs -> attrs, ty
- | `Uncurry, attrs ->
- attrs, Ast_attributes.bs +> ty
- | `Method, attrs ->
- attrs, Ast_attributes.bs_method +> ty
- | `Meth_callback, attrs ->
- attrs, Ast_attributes.bs_this +> ty in
- label, attrs, self.typ self core_type in
- process_getter_setter ~no ~get ~set
- loc label ptyp_attrs core_type acc
- ) methods [] in
- let inner_type =
- { ty
- with ptyp_desc = Ptyp_object(new_methods, closed_flag);
- } in
- if !record_as_js_object then
- Ast_comb.to_js_type loc inner_type
- else inner_type
- | _ -> super.typ self ty
let rec unsafe_mapper : Bs_ast_mapper.mapper =
{ Bs_ast_mapper.default_mapper with
expr = (fun self ({ pexp_loc = loc } as e) ->
match e.pexp_desc with
(** Its output should not be rewritten anymore *)
- | Pexp_extension (
- {txt = ("bs.raw" | "raw"); loc} , payload)
- ->
- Ast_util.handle_raw loc payload
- | Pexp_extension (
- {txt = ("bs.re" | "re"); loc} , payload)
- ->
- Exp.constraint_ ~loc
- (Ast_util.handle_raw ~check_js_regex:true loc payload)
- (Ast_comb.to_js_re_type loc)
- | Pexp_extension ({txt = "bs.external" | "external" ; loc }, payload) ->
- begin match Ast_payload.as_ident payload with
- | Some {txt = Lident x}
- -> Ast_util.handle_external loc x
- (* do we need support [%external gg.xx ]
-
- {[ Js.Undefined.to_opt (if Js.typeof x == "undefined" then x else Js.Undefined.empty ) ]}
- *)
-
- | None | Some _ ->
- Location.raise_errorf ~loc
- "external expects a single identifier"
- end
- | Pexp_extension ({txt = "bs.time"| "time"; loc}, payload)
- ->
- (
- match payload with
- | PStr [{pstr_desc = Pstr_eval (e,_)}] ->
- let locString =
- if loc.loc_ghost then
- "GHOST LOC"
- else
- let loc_start = loc.loc_start in
- let (file, lnum, __) = Location.get_pos_info loc_start in
- Printf.sprintf "%s %d"
- file lnum in
- let e = self.expr self e in
- Exp.sequence ~loc
- (Exp.apply ~loc
- (Exp.ident ~loc {loc;
- txt =
- Ldot (Ldot (Lident "Js", "Console"), "timeStart")
- })
- ["", Exp.constant ~loc (Const_string (locString,None))]
- )
- ( Exp.let_ ~loc Nonrecursive
- [Vb.mk ~loc (Pat.var ~loc {loc; txt = "timed"}) e ;
- ]
- (Exp.sequence ~loc
- (Exp.apply ~loc
- (Exp.ident ~loc {loc;
- txt =
- Ldot (Ldot (Lident "Js", "Console"), "timeEnd")
- })
- ["", Exp.constant ~loc (Const_string (locString,None))]
- )
- (Exp.ident ~loc {loc; txt = Lident "timed"})
- )
- )
- | _ ->
- Location.raise_errorf
- ~loc "expect a boolean expression in the payload"
- )
- | Pexp_extension({txt = "bs.assert" | "assert";loc},payload)
- ->
- (
- match payload with
- | PStr [ {pstr_desc = Pstr_eval( e,_)}] ->
-
- let locString =
- if loc.loc_ghost then
- "ASSERT FAILURE"
- else
- let loc_start = loc.loc_start in
- let (file, lnum, cnum) = Location.get_pos_info loc_start in
- let enum =
- loc.Location.loc_end.Lexing.pos_cnum -
- loc_start.Lexing.pos_cnum + cnum in
- Printf.sprintf "File %S, line %d, characters %d-%d"
- file lnum cnum enum in
- let raiseWithString locString =
- (Exp.apply ~loc
- (Exp.ident ~loc {loc; txt =
- Ldot(Ldot (Lident "Js","Exn"),"raiseError")})
- ["",
-
- Exp.constant (Const_string (locString,None))
- ])
- in
- (match e.pexp_desc with
- | Pexp_construct({txt = Lident "false"},None) ->
- (* The backend will convert [assert false] into a nop later *)
- if !Clflags.no_assert_false then
- Exp.assert_ ~loc
- (Exp.construct ~loc {txt = Lident "false";loc} None)
- else
- (raiseWithString locString)
- | Pexp_constant (Const_string (r, _)) ->
- if !Clflags.noassert then
- Exp.assert_ ~loc (Exp.construct ~loc {txt = Lident "true"; loc} None)
- (* Need special handling to make it type check*)
- else
- raiseWithString r
- | _ ->
- let e = self.expr self e in
- if !Clflags.noassert then
- (* pass down so that it still type check, but the backend will
- make it a nop
- *)
- Exp.assert_ ~loc e
- else
- Exp.ifthenelse ~loc
- (Exp.apply ~loc
- (Exp.ident {loc ; txt = Ldot(Lident "Pervasives","not")})
- ["", e]
- )
- (raiseWithString locString)
- None
- )
- | _ ->
- Location.raise_errorf
- ~loc "expect a boolean expression in the payload"
- )
- (*
- [%%bs.import Bs_internalAVLSet.(a,b,c)]
- *)
- | Pexp_extension
- ({txt = ("bs.node" | "node"); loc},
- payload)
- ->
- let strip s =
- match s with
- | "_module" -> "module"
- | x -> x in
- begin match Ast_payload.as_ident payload with
- | Some {txt = Lident
- ( "__filename"
- | "__dirname"
- | "_module"
- | "require" as name); loc}
- ->
- let exp =
- Ast_util.handle_external loc (strip name) in
- let typ =
- Ast_core_type.lift_option_type
- @@
- if name = "_module" then
- Typ.constr ~loc
- { txt = Ldot (Lident "Node", "node_module") ;
- loc} []
- else if name = "require" then
- (Typ.constr ~loc
- { txt = Ldot (Lident "Node", "node_require") ;
- loc} [] )
- else
- Ast_literal.type_string ~loc () in
- Exp.constraint_ ~loc exp typ
- | Some _ | None ->
- begin match payload with
- | PTyp _ ->
- Location.raise_errorf
- ~loc "Illegal payload, expect an expression payload instead of type payload"
- | PPat _ ->
- Location.raise_errorf
- ~loc "Illegal payload, expect an expression payload instead of pattern payload"
- | _ ->
- Location.raise_errorf
- ~loc "Illegal payload"
- end
-
- end
- |Pexp_constant (Const_string (s, (Some delim)))
+ | Pexp_extension extension ->
+ Ast_exp_extension.handle_extension record_as_js_object e self extension
+ | Pexp_constant (Const_string (s, (Some delim)))
->
if Ext_string.equal delim Literals.unescaped_js_delimiter then
let js_str = Ast_utf8_string.transform loc s in
@@ -510,27 +102,11 @@ let rec unsafe_mapper : Bs_ast_mapper.mapper =
else if Ext_string.equal delim Literals.unescaped_j_delimiter then
Ast_utf8_string_interp.transform_interp loc s
else e
-
- (** [bs.debugger], its output should not be rewritten any more*)
- | Pexp_extension ({txt = ("bs.debugger"|"debugger"); loc} , payload)
- -> {e with pexp_desc = Ast_util.handle_debugger loc payload}
- | Pexp_extension ({txt = ("bs.obj" | "obj"); loc}, payload)
- ->
- begin match payload with
- | PStr [{pstr_desc = Pstr_eval (e,_)}]
- ->
- Ext_ref.non_exn_protect record_as_js_object true
- (fun () -> self.expr self e )
- | _ -> Location.raise_errorf ~loc "Expect an expression here"
- end
- | Pexp_extension({txt ; loc} as lid, PTyp typ)
- when Ext_string.starts_with txt Literals.bs_deriving_dot ->
- self.expr self @@
- Ast_derive.gen_expression lid typ
-
(** End rewriting *)
| Pexp_function cases ->
- begin match Ast_attributes.process_pexp_fun_attributes_rev e.pexp_attributes with
+ begin match
+ Ast_attributes.process_pexp_fun_attributes_rev e.pexp_attributes
+ with
| `Nothing, _ ->
Bs_ast_mapper.default_mapper.expr self e
| `Exn, pexp_attributes ->
@@ -554,102 +130,7 @@ let rec unsafe_mapper : Bs_ast_mapper.mapper =
pexp_attributes }
end
| Pexp_apply (fn, args ) ->
- begin match fn with
- | {pexp_desc =
- Pexp_apply (
- {pexp_desc =
- Pexp_ident {txt = Lident "##" ; loc} ; _},
- [("", obj) ;
- ("", {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _} )
- ]);
- _} -> (* f##paint 1 2 *)
- {e with pexp_desc = Ast_util.method_apply loc self obj name args }
- | {pexp_desc =
- Pexp_apply (
- {pexp_desc =
- Pexp_ident {txt = Lident "#@" ; loc} ; _},
- [("", obj) ;
- ("", {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _} )
- ]);
- _} -> (* f##paint 1 2 *)
- {e with pexp_desc = Ast_util.property_apply loc self obj name args }
-
- | {pexp_desc =
- Pexp_ident {txt = Lident "##" ; loc} ; _}
- ->
- begin match args with
- | [("", obj) ;
- ("", {pexp_desc = Pexp_apply(
- {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _},
- args
- ); pexp_attributes = attrs }
- (* we should warn when we discard attributes *)
- )
- ] -> (* f##(paint 1 2 ) *)
- (* gpr#1063 foo##(bar##baz) we should rewrite (bar##baz)
- first before pattern match.
- currently the pattern match is written in a top down style.
- Another corner case: f##(g a b [@bs])
- *)
- Bs_ast_invariant.warn_unused_attributes attrs ;
- {e with pexp_desc = Ast_util.method_apply loc self obj name args}
- | [("", obj) ;
- ("",
- {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _}
- ) (* f##paint *)
- ] ->
- { e with pexp_desc =
- Ast_util.js_property loc (self.expr self obj) name
- }
-
- | _ ->
- Location.raise_errorf ~loc
- "Js object ## expect syntax like obj##(paint (a,b)) "
- end
- (* we can not use [:=] for precedece cases
- like {[i @@ x##length := 3 ]}
- is parsed as {[ (i @@ x##length) := 3]}
- since we allow user to create Js objects in OCaml, it can be of
- ref type
- {[
- let u = object (self)
- val x = ref 3
- method setX x = self##x := 32
- method getX () = !self##x
- end
- ]}
- *)
- | {pexp_desc =
- Pexp_ident {txt = Lident ("#=" )}
- } ->
- begin match args with
- | ["",
- {pexp_desc =
- Pexp_apply ({pexp_desc = Pexp_ident {txt = Lident "##"}},
- ["", obj;
- "", {pexp_desc = Pexp_ident {txt = Lident name}}
- ]
- )};
- "", arg
- ] ->
- Exp.constraint_ ~loc
- { e with
- pexp_desc =
- Ast_util.method_apply loc self obj
- (name ^ Literals.setter_suffix) ["", arg ] }
- (Ast_literal.type_unit ~loc ())
- | _ -> Bs_ast_mapper.default_mapper.expr self e
- end
- | _ ->
- begin match
- Ext_list.exclude_with_val
- Ast_attributes.is_bs e.pexp_attributes with
- | false, _ -> Bs_ast_mapper.default_mapper.expr self e
- | true, pexp_attributes ->
- {e with pexp_desc = Ast_util.uncurry_fn_apply loc self fn args ;
- pexp_attributes }
- end
- end
+ Ast_exp_apply.handle_exp_apply e self fn args
| Pexp_record (label_exprs, opt_exp) ->
if !record_as_js_object then
(match opt_exp with
@@ -685,7 +166,8 @@ let rec unsafe_mapper : Bs_ast_mapper.mapper =
end
| _ -> Bs_ast_mapper.default_mapper.expr self e
);
- typ = (fun self typ -> handle_core_type Bs_ast_mapper.default_mapper self typ);
+ typ = (fun self typ ->
+ Ast_core_type_class_type.handle_core_type self typ record_as_js_object);
class_type =
(fun self ({pcty_attributes; pcty_loc} as ctd) ->
match Ast_attributes.process_bs pcty_attributes with
@@ -700,7 +182,7 @@ let rec unsafe_mapper : Bs_ast_mapper.mapper =
{ctd with
pcty_desc = Pcty_signature {
pcsig_self ;
- pcsig_fields = Ext_list.fold_right (handle_class_type_field self) pcsig_fields []
+ pcsig_fields = Ast_core_type_class_type.handle_class_type_fields self pcsig_fields
};
pcty_attributes
}
@@ -798,12 +280,7 @@ let rec unsafe_mapper : Bs_ast_mapper.mapper =
| _ -> Bs_ast_mapper.default_mapper.pat self pat
end;
- value_bindings = begin fun self (vbs : Parsetree.value_binding list) ->
- (* Bs_ast_mapper.default_mapper.value_bindings self vbs *)
- List.fold_right (fun vb acc ->
- flattern_tuple_pattern_vb self vb acc
- ) vbs []
- end;
+ value_bindings = Ast_tuple_pattern_flatten.handle_value_bindings;
structure_item = begin fun self (str : Parsetree.structure_item) ->
begin match str.pstr_desc with
| Pstr_extension ( ({txt = ("bs.raw"| "raw") ; loc}, payload), _attrs)
diff --git a/lib/bsb.ml b/lib/bsb.ml
index 2c617cd7af..a41b2b1165 100644
--- a/lib/bsb.ml
+++ b/lib/bsb.ml
@@ -13407,8 +13407,11 @@ let root = OCamlRes.Res.([
"const path = require('path');\n\
const outputDir = path.join(__dirname, \"build/\");\n\
\n\
+ const isProd = process.env.NODE_ENV === 'production';\n\
+ \n\
module.exports = {\n\
\ entry: './src/Index.bs.js',\n\
+ \ mode: isProd ? 'production' : 'development',\n\
\ output: {\n\
\ path: outputDir,\n\
\ publicPath: outputDir,\n\
@@ -13417,7 +13420,78 @@ let root = OCamlRes.Res.([
};\n\
") ;
Dir ("src", [
- File ("Page.re",
+ File ("Index.re",
+ "ReactDOMRe.renderToElementWithId(, \"index1\");\n\
+ \n\
+ ReactDOMRe.renderToElementWithId(, \"index2\");\n\
+ ") ;
+ File ("index.html",
+ "\n\
+ \n\
+ \n\
+ \ \n\
+ \ ReasonReact Examples\n\
+ \n\
+ \n\
+ \ Component 1:\n\
+ \ \n\
+ \ Component 2:\n\
+ \ \n\
+ \n\
+ \ \n\
+ \n\
+ \n\
+ ") ;
+ File ("Component2.re",
+ "/* State declaration */\n\
+ type state = {\n\
+ \ count: int,\n\
+ \ show: bool,\n\
+ };\n\
+ \n\
+ /* Action declaration */\n\
+ type action =\n\
+ \ | Click\n\
+ \ | Toggle;\n\
+ \n\
+ /* Component template declaration.\n\
+ \ Needs to be **after** state and action declarations! */\n\
+ let component = ReasonReact.reducerComponent(\"Example\");\n\
+ \n\
+ /* greeting and children are props. `children` isn't used, therefore ignored.\n\
+ \ We ignore it by prepending it with an underscore */\n\
+ let make = (~greeting, _children) => {\n\
+ \ /* spread the other default fields of component here and override a few */\n\
+ \ ...component,\n\
+ \n\
+ \ initialState: () => {count: 0, show: true},\n\
+ \n\
+ \ /* State transitions */\n\
+ \ reducer: (action, state) =>\n\
+ \ switch (action) {\n\
+ \ | Click => ReasonReact.Update({...state, count: state.count + 1})\n\
+ \ | Toggle => ReasonReact.Update({...state, show: ! state.show})\n\
+ \ },\n\
+ \n\
+ \ render: self => {\n\
+ \ let message =\n\
+ \ \"You've clicked this \" ++ string_of_int(self.state.count) ++ \" times(s)\";\n\
+ \
,\n\
};\n\
- ") ;
- File ("Index.re",
- "ReactDOMRe.renderToElementWithId(, \"index\");\n\
- ") ;
- File ("index.html",
- "\n\
- \n\
- \n\
- \ \n\
- \ Pure Reason Example\n\
- \n\
- \n\
- \ \n\
- \ \n\
- \n\
- \n\
")]) ;
File ("README.md",
"# ${bsb:name}\n\
\n\
- Run this project:\n\
+ ## Run Project\n\
\n\
- ```\n\
+ ```sh\n\
npm install\n\
npm start\n\
# in another tab\n\
npm run webpack\n\
```\n\
- \n\
- After you see the webpack compilation succeed (the `npm run webpack` step), open up the nested html files in `src/*` (**no server needed!**). Then modify whichever file in `src` and refresh the page to see the changes.\n\
+ After you see the webpack compilation succeed (the `npm run webpack` step), open up `src/index.html` (**no server needed!**). Then modify whichever `.re` file in `src` and refresh the page to see the changes.\n\
\n\
**For more elaborate ReasonReact examples**, please see https://github.com/reasonml-community/reason-react-example\n\
+ \n\
+ ## Build for Production\n\
+ \n\
+ ```sh\n\
+ npm run build\n\
+ npm run webpack:production\n\
+ ```\n\
+ \n\
+ This will replace the development artifact `build/Index.js` for an optimized version.\n\
") ;
File ("package.json",
"{\n\
@@ -13481,7 +13549,8 @@ let root = OCamlRes.Res.([
\ \"start\": \"bsb -make-world -w\",\n\
\ \"clean\": \"bsb -clean-world\",\n\
\ \"test\": \"echo \\\"Error: no test specified\\\" && exit 1\",\n\
- \ \"webpack\": \"webpack -w\"\n\
+ \ \"webpack\": \"webpack -w\",\n\
+ \ \"webpack:production\": \"NODE_ENV=production webpack\"\n\
\ },\n\
\ \"keywords\": [\n\
\ \"BuckleScript\"\n\
@@ -13489,13 +13558,14 @@ let root = OCamlRes.Res.([
\ \"author\": \"\",\n\
\ \"license\": \"MIT\",\n\
\ \"dependencies\": {\n\
- \ \"react\": \"^15.4.2\",\n\
- \ \"react-dom\": \"^15.4.2\",\n\
- \ \"reason-react\": \">=0.3.0\"\n\
+ \ \"react\": \"^16.2.0\",\n\
+ \ \"react-dom\": \"^16.2.0\",\n\
+ \ \"reason-react\": \">=0.3.4\"\n\
\ },\n\
\ \"devDependencies\": {\n\
\ \"bs-platform\": \"^${bsb:bs-version}\",\n\
- \ \"webpack\": \"^3.8.1\"\n\
+ \ \"webpack\": \"^4.0.1\",\n\
+ \ \"webpack-cli\": \"^2.0.10\"\n\
\ }\n\
}\n\
") ;
@@ -13514,7 +13584,7 @@ let root = OCamlRes.Res.([
\ \"subdirs\" : true\n\
\ },\n\
\ \"package-specs\": [{\n\
- \ \"module\": \"commonjs\",\n\
+ \ \"module\": \"es6\",\n\
\ \"in-source\": true\n\
\ }],\n\
\ \"suffix\": \".bs.js\",\n\
diff --git a/lib/bsdep.d b/lib/bsdep.d
index 1b9e32b10e..66667bb454 100644
--- a/lib/bsdep.d
+++ b/lib/bsdep.d
@@ -72,6 +72,7 @@
../lib/bsdep.ml : ./common/lam_methname.mli
../lib/bsdep.ml : ./ext/string_hash_set.mli
../lib/bsdep.ml : ./syntax/ast_core_type.ml
+../lib/bsdep.ml : ./syntax/ast_exp_apply.ml
../lib/bsdep.ml : ./syntax/ast_signature.ml
../lib/bsdep.ml : ./syntax/ast_structure.ml
../lib/bsdep.ml : ./syntax/bs_ast_mapper.ml
@@ -88,6 +89,7 @@
../lib/bsdep.ml : ../vendor/ocaml/utils/warnings.ml
../lib/bsdep.ml : ./syntax/ast_attributes.ml
../lib/bsdep.ml : ./syntax/ast_core_type.mli
+../lib/bsdep.ml : ./syntax/ast_exp_apply.mli
../lib/bsdep.ml : ./syntax/ast_signature.mli
../lib/bsdep.ml : ./syntax/ast_structure.mli
../lib/bsdep.ml : ./syntax/bs_ast_mapper.mli
@@ -112,6 +114,7 @@
../lib/bsdep.ml : ../vendor/ocaml/parsing/location.mli
../lib/bsdep.ml : ../vendor/ocaml/parsing/longident.ml
../lib/bsdep.ml : ../vendor/ocaml/parsing/syntaxerr.ml
+../lib/bsdep.ml : ./syntax/ast_exp_extension.ml
../lib/bsdep.ml : ./syntax/bs_ast_invariant.mli
../lib/bsdep.ml : ./syntax/external_arg_spec.ml
../lib/bsdep.ml : ./syntax/external_process.mli
@@ -121,6 +124,7 @@
../lib/bsdep.ml : ../vendor/ocaml/parsing/longident.mli
../lib/bsdep.ml : ../vendor/ocaml/parsing/parsetree.mli
../lib/bsdep.ml : ../vendor/ocaml/parsing/syntaxerr.mli
+../lib/bsdep.ml : ./syntax/ast_exp_extension.mli
../lib/bsdep.ml : ./syntax/external_arg_spec.mli
../lib/bsdep.ml : ./syntax/external_ffi_types.ml
../lib/bsdep.ml : ../vendor/ocaml/parsing/ast_helper.mli
@@ -139,3 +143,7 @@
../lib/bsdep.ml : ./syntax/ast_derive_projector.mli
../lib/bsdep.ml : ./syntax/ast_utf8_string_interp.ml
../lib/bsdep.ml : ./syntax/ast_utf8_string_interp.mli
+../lib/bsdep.ml : ./syntax/ast_core_type_class_type.ml
+../lib/bsdep.ml : ./syntax/ast_core_type_class_type.mli
+../lib/bsdep.ml : ./syntax/ast_tuple_pattern_flatten.ml
+../lib/bsdep.ml : ./syntax/ast_tuple_pattern_flatten.mli
diff --git a/lib/bsdep.ml b/lib/bsdep.ml
index 7d921f1395..f7151214a1 100644
--- a/lib/bsdep.ml
+++ b/lib/bsdep.ml
@@ -28616,8 +28616,8 @@ let bs_set : attr
end
-module Ast_signature : sig
-#1 "ast_signature.mli"
+module Ast_exp : sig
+#1 "ast_exp.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -28642,13 +28642,10 @@ module Ast_signature : sig
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-type item = Parsetree.signature_item
-type t = item list
-
+type t = Parsetree.expression
-val fuseAll : ?loc:Ast_helper.loc -> t -> item
end = struct
-#1 "ast_signature.ml"
+#1 "ast_exp.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -28673,17 +28670,11 @@ end = struct
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-type item = Parsetree.signature_item
-type t = item list
-
-open Ast_helper
+type t = Parsetree.expression
-let fuseAll ?(loc=Location.none) (t : t) : item =
- Sig.include_ ~loc (Incl.mk ~loc (Mty.signature ~loc t))
-
end
-module Ast_structure : sig
-#1 "ast_structure.mli"
+module Ast_external_mk : sig
+#1 "ast_external_mk.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -28708,25 +28699,35 @@ module Ast_structure : sig
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
+(**
+ [local_module loc ~pval_prim ~pval_type args]
+ generate such code
+ {[
+ let module J = struct
+ external unsafe_expr : pval_type = pval_prim
+ end in
+ J.unssafe_expr args
+ ]}
+*)
+val local_external : Location.t ->
+ ?pval_attributes:Parsetree.attributes ->
+ pval_prim:string list ->
+ pval_type:Parsetree.core_type ->
+ ?local_module_name:string ->
+ ?local_fun_name:string ->
+ (string * Parsetree.expression) list -> Parsetree.expression_desc
-type item = Parsetree.structure_item
-
-type t = item list
-
-
-val fuseAll: ?loc:Ast_helper.loc -> t -> item
-
-(* val fuse_with_constraint:
- ?loc:Ast_helper.loc ->
- Parsetree.type_declaration list ->
- t ->
- Ast_signature.t ->
- item *)
-
-val constraint_ : ?loc:Ast_helper.loc -> t -> Ast_signature.t -> item
+val local_extern_cont :
+ Location.t ->
+ ?pval_attributes:Parsetree.attributes ->
+ pval_prim:string list ->
+ pval_type:Parsetree.core_type ->
+ ?local_module_name:string ->
+ ?local_fun_name:string ->
+ (Parsetree.expression -> Parsetree.expression) -> Parsetree.expression_desc
end = struct
-#1 "ast_structure.ml"
+#1 "ast_external_mk.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -28751,39 +28752,73 @@ end = struct
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-type item = Parsetree.structure_item
-
-type t = item list
-
-open Ast_helper
-
+let 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_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 fuseAll ?(loc=Location.none) (t : t) : item =
- Str.include_ ~loc
- (Incl.mk ~loc (Mod.structure ~loc t ))
-
-(* let fuse_with_constraint
- ?(loc=Location.none)
- (item : Parsetree.type_declaration list ) (t : t) (coercion) =
- Str.include_ ~loc
- (Incl.mk ~loc
- (Mod.constraint_
- (Mod.structure ~loc
- ({pstr_loc = loc; pstr_desc = Pstr_type item} :: t) )
- (
- Mty.signature ~loc
- ({psig_loc = loc; psig_desc = Psig_type item} :: coercion)
- )
- )
- ) *)
-let constraint_ ?(loc=Location.none) (stru : t) (sign : Ast_signature.t) =
- Str.include_ ~loc
- (Incl.mk ~loc
- (Mod.constraint_ ~loc (Mod.structure ~loc stru) (Mty.signature ~loc sign)))
+let local_extern_cont loc
+ ?(pval_attributes=[])
+ ~pval_prim
+ ~pval_type
+ ?(local_module_name = "J")
+ ?(local_fun_name = "unsafe_expr")
+ (cb : Parsetree.expression -> 'a)
+ : 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_attributes };
+ pstr_loc = loc;
+ }];
+ pmod_loc = loc;
+ pmod_attributes = []},
+ cb {pexp_desc = Pexp_ident {txt = Ldot (Lident local_module_name, local_fun_name);
+ loc};
+ pexp_attributes = [] ;
+ pexp_loc = loc}
+)
end
-module Ast_derive : sig
-#1 "ast_derive.mli"
+module Ast_pat : sig
+#1 "ast_pat.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -28808,51 +28843,19 @@ module Ast_derive : sig
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-type tdcls = Parsetree.type_declaration list
-
-type gen = {
- structure_gen : tdcls -> bool -> Ast_structure.t ;
- signature_gen : tdcls -> bool -> Ast_signature.t ;
- expression_gen : (Parsetree.core_type -> Parsetree.expression) option ;
-}
-
-(**
- [register name cb]
- example: [register "accessors" cb]
-*)
-val register :
- string ->
- (Parsetree.expression option -> gen) ->
- unit
-
-(* val gen_structure:
- tdcls ->
- Ast_payload.action list ->
- bool ->
- Ast_structure.t *)
-
-val gen_signature:
- tdcls ->
- Ast_payload.action list ->
- bool ->
- Ast_signature.t
+type t = Parsetree.pattern
+val is_unit_cont : yes:'a -> no:'a -> t -> 'a
-val gen_expression :
- string Asttypes.loc ->
- Parsetree.core_type ->
- Parsetree.expression
+(** [arity_of_fun pat e] tells the arity of
+ expression [fun pat -> e]*)
+val arity_of_fun : t -> Parsetree.expression -> int
+val is_single_variable_pattern_conservative : t -> bool
-val gen_structure_signature :
- Location.t ->
- Parsetree.type_declaration list ->
- Ast_payload.action ->
- bool ->
- Parsetree.structure_item
end = struct
-#1 "ast_derive.ml"
+#1 "ast_pat.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -28877,512 +28880,921 @@ end = struct
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-type tdcls = Parsetree.type_declaration list
-
-type gen = {
- structure_gen : tdcls -> bool -> Ast_structure.t ;
- signature_gen : tdcls -> bool -> Ast_signature.t ;
- expression_gen : (Parsetree.core_type -> Parsetree.expression) option ;
-}
-(* the first argument is [config] payload
- {[
- { x = {uu} }
- ]}
-*)
-type derive_table =
- (Parsetree.expression option -> gen) String_map.t
+type t = Parsetree.pattern
-let derive_table : derive_table ref = ref String_map.empty
-let register key value =
- derive_table := String_map.add key value !derive_table
+let is_unit_cont ~yes ~no (p : t) =
+ match p with
+ | {ppat_desc = Ppat_construct({txt = Lident "()"}, None)}
+ -> yes
+ | _ -> no
+(** [arity_of_fun pat e] tells the arity of
+ expression [fun pat -> e]
+*)
+let arity_of_fun
+ (pat : Parsetree.pattern)
+ (e : Parsetree.expression) =
+ let rec aux (e : Parsetree.expression) =
+ match e.pexp_desc with
+ | Pexp_fun ("", None, pat, e) ->
+ 1 + aux e
+ | Pexp_fun _
+ -> Location.raise_errorf
+ ~loc:e.pexp_loc "Label is not allowed in JS object"
+ | _ -> 0 in
+ is_unit_cont ~yes:0 ~no:1 pat + aux e
-(* let gen_structure
- (tdcls : tdcls)
- (actions : Ast_payload.action list )
- (explict_nonrec : bool )
- : Ast_structure.t =
- Ext_list.flat_map
- (fun action ->
- (Ast_payload.table_dispatch !derive_table action).structure_gen
- tdcls explict_nonrec) actions *)
-let gen_signature
- tdcls
- (actions : Ast_payload.action list )
- (explict_nonrec : bool )
- : Ast_signature.t =
- Ext_list.flat_map
- (fun action ->
- (Ast_payload.table_dispatch !derive_table action).signature_gen
- tdcls explict_nonrec) actions
+let rec is_single_variable_pattern_conservative (p : t ) =
+ match p.ppat_desc with
+ | Parsetree.Ppat_any
+ | Parsetree.Ppat_var _ -> true
+ | Parsetree.Ppat_alias (p,_)
+ | Parsetree.Ppat_constraint (p, _) ->
+ is_single_variable_pattern_conservative p
+
+ | _ -> false
-(** used for cases like [%sexp] *)
-let gen_expression ({Asttypes.txt ; loc}) typ =
- let txt = Ext_string.tail_from txt (String.length Literals.bs_deriving_dot) in
- match (Ast_payload.table_dispatch !derive_table
- ({txt ; loc}, None)).expression_gen with
- | None ->
- Bs_syntaxerr.err loc (Unregistered txt)
+end
+module Bs_ast_mapper : sig
+#1 "bs_ast_mapper.mli"
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
- | Some f -> f typ
+(** The interface of a -ppx rewriter
-open Ast_helper
-let gen_structure_signature
- loc
- (tdcls : tdcls)
- (action : Ast_payload.action)
- (explicit_nonrec : bool) =
- let derive_table = !derive_table in
- let u =
- Ast_payload.table_dispatch derive_table action in
+ A -ppx rewriter is a program that accepts a serialized abstract syntax
+ tree and outputs another, possibly modified, abstract syntax tree.
+ This module encapsulates the interface between the compiler and
+ the -ppx rewriters, handling such details as the serialization format,
+ forwarding of command-line flags, and storing state.
- let a = u.structure_gen tdcls explicit_nonrec in
- let b = u.signature_gen tdcls explicit_nonrec in
- Str.include_ ~loc
- (Incl.mk ~loc
- (Mod.constraint_ ~loc
- (Mod.structure ~loc a)
- (Mty.signature ~loc b )
- )
- )
-end
-module Ast_derive_util : sig
-#1 "ast_derive_util.mli"
-(* Copyright (C) 2017 Authors of BuckleScript
- *
- * 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. *)
+ {!mapper} allows to implement AST rewriting using open recursion.
+ A typical mapper would be based on {!default_mapper}, a deep
+ identity mapper, and will fall back on it for handling the syntax it
+ does not modify. For example:
-(** Given a type declaration, extaract the type expression, mostly
- used in code gen later
- *)
- val core_type_of_type_declaration :
- Parsetree.type_declaration -> Parsetree.core_type
+ {[
+open Asttypes
+open Parsetree
+open Ast_mapper
-val new_type_of_type_declaration :
- Parsetree.type_declaration ->
- string ->
- Parsetree.core_type * Parsetree.type_declaration
+let test_mapper argv =
+ { default_mapper with
+ expr = fun mapper expr ->
+ match expr with
+ | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} ->
+ Ast_helper.Exp.constant (Const_int 42)
+ | other -> default_mapper.expr mapper other; }
-val lift_string_list_to_array : string list -> Parsetree.expression
-val lift_int : int -> Parsetree.expression
-val lift_int_list_to_array : int list -> Parsetree.expression
-val mk_fun :
- loc:Location.t ->
- Parsetree.core_type ->
- string -> Parsetree.expression -> Parsetree.expression
-val destruct_label_declarations :
- loc:Location.t ->
- string ->
- Parsetree.label_declaration list ->
- (Parsetree.core_type * Parsetree.expression) list * string list
+let () =
+ register "ppx_test" test_mapper]}
-val notApplicable:
- Location.t ->
- string ->
- unit
+ This -ppx rewriter, which replaces [[%test]] in expressions with
+ the constant [42], can be compiled using
+ [ocamlc -o ppx_test -I +compiler-libs ocamlcommon.cma ppx_test.ml].
-val invalid_config : Parsetree.expression -> 'a
+ *)
+
+ open Parsetree
+
+ (** {2 A generic Parsetree mapper} *)
+
+ type mapper = {
+ attribute: mapper -> attribute -> attribute;
+ attributes: mapper -> attribute list -> attribute list;
+ case: mapper -> case -> case;
+ cases: mapper -> case list -> case list;
+ class_declaration: mapper -> class_declaration -> class_declaration;
+ class_description: mapper -> class_description -> class_description;
+ class_expr: mapper -> class_expr -> class_expr;
+ class_field: mapper -> class_field -> class_field;
+ class_signature: mapper -> class_signature -> class_signature;
+ class_structure: mapper -> class_structure -> class_structure;
+ class_type: mapper -> class_type -> class_type;
+ class_type_declaration: mapper -> class_type_declaration
+ -> class_type_declaration;
+ class_type_field: mapper -> class_type_field -> class_type_field;
+ constructor_declaration: mapper -> constructor_declaration
+ -> constructor_declaration;
+ expr: mapper -> expression -> expression;
+ extension: mapper -> extension -> extension;
+ extension_constructor: mapper -> extension_constructor
+ -> extension_constructor;
+ include_declaration: mapper -> include_declaration -> include_declaration;
+ include_description: mapper -> include_description -> include_description;
+ label_declaration: mapper -> label_declaration -> label_declaration;
+ location: mapper -> Location.t -> Location.t;
+ module_binding: mapper -> module_binding -> module_binding;
+ module_declaration: mapper -> module_declaration -> module_declaration;
+ module_expr: mapper -> module_expr -> module_expr;
+ module_type: mapper -> module_type -> module_type;
+ module_type_declaration: mapper -> module_type_declaration
+ -> module_type_declaration;
+ open_description: mapper -> open_description -> open_description;
+ pat: mapper -> pattern -> pattern;
+ payload: mapper -> payload -> payload;
+ signature: mapper -> signature -> signature;
+ signature_item: mapper -> signature_item -> signature_item;
+ structure: mapper -> structure -> structure;
+ structure_item: mapper -> structure_item -> structure_item;
+ typ: mapper -> core_type -> core_type;
+ type_declaration: mapper -> type_declaration -> type_declaration;
+ type_extension: mapper -> type_extension -> type_extension;
+ type_kind: mapper -> type_kind -> type_kind;
+ value_binding: mapper -> value_binding -> value_binding;
+(* XXXXX *)
+ value_bindings_rec: mapper -> value_binding list -> value_binding list;
+ value_bindings: mapper -> value_binding list -> value_binding list;
+(* XXXXX *)
+ value_description: mapper -> value_description -> value_description;
+ with_constraint: mapper -> with_constraint -> with_constraint;
+ }
+ (** A mapper record implements one "method" per syntactic category,
+ using an open recursion style: each method takes as its first
+ argument the mapper to be applied to children in the syntax
+ tree. *)
+
+ val default_mapper: mapper
+ (** A default mapper, which implements a "deep identity" mapping. *)
+
end = struct
-#1 "ast_derive_util.ml"
-(* 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. *)
+#1 "bs_ast_mapper.ml"
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
-open Ast_helper
+(* A generic Parsetree mapping class *)
+(* Adapted for BUcklescript with more flexibilty*)
-let core_type_of_type_declaration
- (tdcl : Parsetree.type_declaration) =
- match tdcl with
- | {ptype_name = {txt ; loc};
- ptype_params ;
- } ->
- Typ.constr
- {txt = Lident txt ; loc}
- (Ext_list.map fst ptype_params)
+[@@@ocaml.warning "+9"]
+(* Ensure that record patterns don't miss any field. *)
-let new_type_of_type_declaration
- (tdcl : Parsetree.type_declaration) newName =
- match tdcl with
- | {ptype_name = { loc};
- ptype_params ;
- } ->
- (Typ.constr
- {txt = Lident newName ; loc}
- (Ext_list.map fst ptype_params),
- { Parsetree.ptype_params = tdcl.ptype_params;
- ptype_name = {txt = newName;loc};
- ptype_kind = Ptype_abstract;
- ptype_attributes = [];
- ptype_loc = tdcl.ptype_loc;
- ptype_cstrs = []; ptype_private = Public; ptype_manifest = None}
- )
-
-let lift_string_list_to_array (labels : string list) =
- Exp.array
- (Ext_list.map (fun s -> Exp.constant (Const_string (s, None)))
- labels)
-let lift_int i = Exp.constant (Const_int i)
-let lift_int_list_to_array (labels : int list) =
- Exp.array (Ext_list.map lift_int labels)
+open Asttypes
+open Parsetree
+open Ast_helper
+open Location
+type mapper = {
+ attribute: mapper -> attribute -> attribute;
+ attributes: mapper -> attribute list -> attribute list;
+ case: mapper -> case -> case;
+ cases: mapper -> case list -> case list;
+ class_declaration: mapper -> class_declaration -> class_declaration;
+ class_description: mapper -> class_description -> class_description;
+ class_expr: mapper -> class_expr -> class_expr;
+ class_field: mapper -> class_field -> class_field;
+ class_signature: mapper -> class_signature -> class_signature;
+ class_structure: mapper -> class_structure -> class_structure;
+ class_type: mapper -> class_type -> class_type;
+ class_type_declaration: mapper -> class_type_declaration
+ -> class_type_declaration;
+ class_type_field: mapper -> class_type_field -> class_type_field;
+ constructor_declaration: mapper -> constructor_declaration
+ -> constructor_declaration;
+ expr: mapper -> expression -> expression;
+ extension: mapper -> extension -> extension;
+ extension_constructor: mapper -> extension_constructor
+ -> extension_constructor;
+ include_declaration: mapper -> include_declaration -> include_declaration;
+ include_description: mapper -> include_description -> include_description;
+ label_declaration: mapper -> label_declaration -> label_declaration;
+ location: mapper -> Location.t -> Location.t;
+ module_binding: mapper -> module_binding -> module_binding;
+ module_declaration: mapper -> module_declaration -> module_declaration;
+ module_expr: mapper -> module_expr -> module_expr;
+ module_type: mapper -> module_type -> module_type;
+ module_type_declaration: mapper -> module_type_declaration
+ -> module_type_declaration;
+ open_description: mapper -> open_description -> open_description;
+ pat: mapper -> pattern -> pattern;
+ payload: mapper -> payload -> payload;
+ signature: mapper -> signature -> signature;
+ signature_item: mapper -> signature_item -> signature_item;
+ structure: mapper -> structure -> structure;
+ structure_item: mapper -> structure_item -> structure_item;
+ typ: mapper -> core_type -> core_type;
+ type_declaration: mapper -> type_declaration -> type_declaration;
+ type_extension: mapper -> type_extension -> type_extension;
+ type_kind: mapper -> type_kind -> type_kind;
+ value_binding: mapper -> value_binding -> value_binding;
+(* XXXX *)
+ value_bindings_rec : mapper -> value_binding list -> value_binding list;
+ value_bindings : mapper -> value_binding list -> value_binding list;
+(* XXXXX *)
+ value_description: mapper -> value_description -> value_description;
+ with_constraint: mapper -> with_constraint -> with_constraint;
+}
-let mk_fun ~loc (typ : Parsetree.core_type)
- (value : string) body
- : Parsetree.expression =
- Exp.fun_
- "" None
- (Pat.constraint_ (Pat.var {txt = value ; loc}) typ)
- body
+let map_fst f (x, y) = (f x, y)
+let map_snd f (x, y) = (x, f y)
+let map_tuple f1 f2 (x, y) = (f1 x, f2 y)
+let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
+let map_opt f = function None -> None | Some x -> Some (f x)
-let destruct_label_declarations ~loc
- (arg_name : string)
- (labels : Parsetree.label_declaration list) :
- (Parsetree.core_type * Parsetree.expression) list * string list
- =
- Ext_list.fold_right
- (fun ({pld_name = {txt}; pld_type} : Parsetree.label_declaration)
- (core_type_exps, labels) ->
- ((pld_type,
- Exp.field (Exp.ident {txt = Lident arg_name ; loc})
- {txt = Lident txt ; loc}) :: core_type_exps),
- txt :: labels
- ) labels ([], [])
+let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt}
-let notApplicable
- loc derivingName =
- Location.prerr_warning
- loc
- (Warnings.Bs_derive_warning ( derivingName ^ " not applicable to this type"))
-
-let invalid_config (config : Parsetree.expression) =
- Location.raise_errorf ~loc:config.pexp_loc "such configuration is not supported"
-
-end
-module Ast_derive_abstract : sig
-#1 "ast_derive_abstract.mli"
-(* Copyright (C) 2017 Authors of BuckleScript
- *
- * 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 T = struct
+ (* Type expressions for the core language *)
-val handleTdclsInStr :
- Parsetree.type_declaration list -> Parsetree.structure
+ let row_field sub = function
+ | Rtag (l, attrs, b, tl) ->
+ Rtag (l, sub.attributes sub attrs, b, List.map (sub.typ sub) tl)
+ | Rinherit t -> Rinherit (sub.typ sub t)
-val handleTdclsInSig:
- Parsetree.type_declaration list -> Parsetree.signature
-end = struct
-#1 "ast_derive_abstract.ml"
-(* Copyright (C) 2017 Authors of BuckleScript
- *
- * 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 map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} =
+ let open Typ in
+ let loc = sub.location sub loc in
+ let attrs = sub.attributes sub attrs in
+ match desc with
+ | Ptyp_any -> any ~loc ~attrs ()
+ | Ptyp_var s -> var ~loc ~attrs s
+ | Ptyp_arrow (lab, t1, t2) ->
+ arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2)
+ | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl)
+ | Ptyp_constr (lid, tl) ->
+ constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
+ | Ptyp_object (l, o) ->
+ let f (s, a, t) = (s, sub.attributes sub a, sub.typ sub t) in
+ object_ ~loc ~attrs (List.map f l) o
+ | Ptyp_class (lid, tl) ->
+ class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
+ | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s
+ | Ptyp_variant (rl, b, ll) ->
+ variant ~loc ~attrs (List.map (row_field sub) rl) b ll
+ | Ptyp_poly (sl, t) -> poly ~loc ~attrs sl (sub.typ sub t)
+ | Ptyp_package (lid, l) ->
+ package ~loc ~attrs (map_loc sub lid)
+ (List.map (map_tuple (map_loc sub) (sub.typ sub)) l)
+ | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x)
+ let map_type_declaration sub
+ {ptype_name; ptype_params; ptype_cstrs;
+ ptype_kind;
+ ptype_private;
+ ptype_manifest;
+ ptype_attributes;
+ ptype_loc} =
+ Type.mk (map_loc sub ptype_name)
+ ~params:(List.map (map_fst (sub.typ sub)) ptype_params)
+ ~priv:ptype_private
+ ~cstrs:(List.map
+ (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub))
+ ptype_cstrs)
+ ~kind:(sub.type_kind sub ptype_kind)
+ ?manifest:(map_opt (sub.typ sub) ptype_manifest)
+ ~loc:(sub.location sub ptype_loc)
+ ~attrs:(sub.attributes sub ptype_attributes)
-let derivingName = "abstract"
-module U = Ast_derive_util
-open Ast_helper
-type tdcls = Parsetree.type_declaration list
+ let map_type_kind sub = function
+ | Ptype_abstract -> Ptype_abstract
+ | Ptype_variant l ->
+ Ptype_variant (List.map (sub.constructor_declaration sub) l)
+ | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l)
+ | Ptype_open -> Ptype_open
-let handle_config (config : Parsetree.expression option) =
- match config with
- | Some config ->
- U.invalid_config config
- | None -> ()
+ let map_type_extension sub
+ {ptyext_path; ptyext_params;
+ ptyext_constructors;
+ ptyext_private;
+ ptyext_attributes} =
+ Te.mk
+ (map_loc sub ptyext_path)
+ (List.map (sub.extension_constructor sub) ptyext_constructors)
+ ~params:(List.map (map_fst (sub.typ sub)) ptyext_params)
+ ~priv:ptyext_private
+ ~attrs:(sub.attributes sub ptyext_attributes)
-(* see #2337
- TODO: relax it to allow (int -> int [@bs])
-*)
-let rec checkNotFunciton (ty : Parsetree.core_type) =
- match ty.ptyp_desc with
- | Ptyp_poly (_,ty) -> checkNotFunciton ty
- | Ptyp_alias (ty,_) -> checkNotFunciton ty
- | Ptyp_arrow _ ->
- Location.raise_errorf
- ~loc:ty.ptyp_loc
- "syntactic function type is not allowed when working with abstract bs.deriving, create a named type as work around"
- | Ptyp_any
- | Ptyp_var _
- | Ptyp_tuple _
- | Ptyp_constr _
- | Ptyp_object _
- | Ptyp_class _
- | Ptyp_variant _
- | Ptyp_package _
- | Ptyp_extension _ -> ()
-let handleTdcl (tdcl : Parsetree.type_declaration) =
- let core_type = U.core_type_of_type_declaration tdcl in
- let loc = tdcl.ptype_loc in
- let name = tdcl.ptype_name.txt in
- let newTdcl = {
- tdcl with
- ptype_kind = Ptype_abstract;
- ptype_attributes = [];
- (* avoid non-terminating*)
- } in
- match tdcl.ptype_kind with
- | Ptype_record label_declarations ->
- let ty =
- Ext_list.fold_right (fun (label_declaration : Parsetree.label_declaration) acc ->
- Typ.arrow
- label_declaration.pld_name.txt label_declaration.pld_type acc
- ) label_declarations core_type in
- let setter_accessor =
- Ext_list.fold_right (fun (x: Parsetree.label_declaration) acc ->
- let pld_name = x.pld_name.txt in
- let pld_loc = x.pld_name.loc in
- let pld_type = x.pld_type in
- let () = checkNotFunciton pld_type in
- let setter =
- Val.mk
- {loc = pld_loc; txt = pld_name}
- ~attrs:[Ast_attributes.bs_get]
- ~prim:[pld_name]
- (Typ.arrow "" core_type pld_type) :: acc in
- match x.pld_mutable with
- | Mutable ->
- Val.mk
- {loc = pld_loc; txt = pld_name ^ "Set"}
- ~attrs:[Ast_attributes.bs_set]
- ~prim:[pld_name]
- (Typ.arrow "" core_type (Typ.arrow "" pld_type (Ast_literal.type_unit ()))) :: setter
- | Immutable -> setter
- ) label_declarations []
- in
-
- newTdcl,
- (match tdcl.ptype_private with
- | Private -> setter_accessor
- | Public ->
- let maker =
- Val.mk {loc; txt = name}
- ~attrs:[Ast_attributes.bs_obj]
- ~prim:[""] ty in
- (maker :: setter_accessor))
-
- | Ptype_abstract
- | Ptype_variant _
- | Ptype_open ->
- (* Looks obvious that it does not make sense to warn *)
- (* U.notApplicable tdcl.ptype_loc derivingName; *)
- tdcl, []
-
-let handleTdclsInStr tdcls =
- let tdcls, code =
- List.fold_right (fun tdcl (tdcls, sts) ->
- match handleTdcl tdcl with
- ntdcl, value_descriptions ->
- ntdcl::tdcls,
- Ext_list.map_append (fun x -> Str.primitive x) value_descriptions sts
-
- ) tdcls ([],[]) in
- Str.type_ tdcls :: code
-(* still need perform transformation for non-abstract type*)
+ let map_extension_constructor_kind sub = function
+ Pext_decl(ctl, cto) ->
+ Pext_decl(List.map (sub.typ sub) ctl, map_opt (sub.typ sub) cto)
+ | Pext_rebind li ->
+ Pext_rebind (map_loc sub li)
-let handleTdclsInSig tdcls =
- let tdcls, code =
- List.fold_right (fun tdcl (tdcls, sts) ->
- match handleTdcl tdcl with
- ntdcl, value_descriptions ->
- ntdcl::tdcls,
- Ext_list.map_append (fun x -> Sig.value x) value_descriptions sts
+ let map_extension_constructor sub
+ {pext_name;
+ pext_kind;
+ pext_loc;
+ pext_attributes} =
+ Te.constructor
+ (map_loc sub pext_name)
+ (map_extension_constructor_kind sub pext_kind)
+ ~loc:(sub.location sub pext_loc)
+ ~attrs:(sub.attributes sub pext_attributes)
- ) tdcls ([],[]) in
- Sig.type_ tdcls :: code
end
-module Ext_pervasives : sig
-#1 "ext_pervasives.mli"
-(* 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 CT = struct
+ (* Type expressions for the class language *)
+ let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} =
+ let open Cty in
+ let loc = sub.location sub loc in
+ let attrs = sub.attributes sub attrs in
+ match desc with
+ | Pcty_constr (lid, tys) ->
+ constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys)
+ | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x)
+ | Pcty_arrow (lab, t, ct) ->
+ arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct)
+ | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x)
+ let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs}
+ =
+ let open Ctf in
+ let loc = sub.location sub loc in
+ let attrs = sub.attributes sub attrs in
+ match desc with
+ | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct)
+ | Pctf_val (s, m, v, t) -> val_ ~loc ~attrs s m v (sub.typ sub t)
+ | Pctf_method (s, p, v, t) -> method_ ~loc ~attrs s p v (sub.typ sub t)
+ | Pctf_constraint (t1, t2) ->
+ constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2)
+ | Pctf_attribute x -> attribute ~loc (sub.attribute sub x)
+ | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x)
+ let map_signature sub {pcsig_self; pcsig_fields} =
+ Csig.mk
+ (sub.typ sub pcsig_self)
+ (List.map (sub.class_type_field sub) pcsig_fields)
+end
-(** Extension to standard library [Pervavives] module, safe to open
- *)
+module MT = struct
+ (* Type expressions for the module language *)
-external reraise: exn -> 'a = "%reraise"
+ let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} =
+ let open Mty in
+ let loc = sub.location sub loc in
+ let attrs = sub.attributes sub attrs in
+ match desc with
+ | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s)
+ | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s)
+ | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg)
+ | Pmty_functor (s, mt1, mt2) ->
+ functor_ ~loc ~attrs (map_loc sub s)
+ (Misc.may_map (sub.module_type sub) mt1)
+ (sub.module_type sub mt2)
+ | Pmty_with (mt, l) ->
+ with_ ~loc ~attrs (sub.module_type sub mt)
+ (List.map (sub.with_constraint sub) l)
+ | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me)
+ | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x)
-val finally : 'a -> ('a -> 'c) -> ('a -> 'b) -> 'b
+ let map_with_constraint sub = function
+ | Pwith_type (lid, d) ->
+ Pwith_type (map_loc sub lid, sub.type_declaration sub d)
+ | Pwith_module (lid, lid2) ->
+ Pwith_module (map_loc sub lid, map_loc sub lid2)
+ | Pwith_typesubst d -> Pwith_typesubst (sub.type_declaration sub d)
+ | Pwith_modsubst (s, lid) ->
+ Pwith_modsubst (map_loc sub s, map_loc sub lid)
-val with_file_as_chan : string -> (out_channel -> 'a) -> 'a
+ let map_signature_item sub {psig_desc = desc; psig_loc = loc} =
+ let open Sig in
+ let loc = sub.location sub loc in
+ match desc with
+ | Psig_value vd -> value ~loc (sub.value_description sub vd)
+ | Psig_type l -> type_ ~loc (List.map (sub.type_declaration sub) l)
+ | Psig_typext te -> type_extension ~loc (sub.type_extension sub te)
+ | Psig_exception ed -> exception_ ~loc (sub.extension_constructor sub ed)
+ | Psig_module x -> module_ ~loc (sub.module_declaration sub x)
+ | Psig_recmodule l ->
+ rec_module ~loc (List.map (sub.module_declaration sub) l)
+ | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x)
+ | Psig_open x -> open_ ~loc (sub.open_description sub x)
+ | Psig_include x -> include_ ~loc (sub.include_description sub x)
+ | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l)
+ | Psig_class_type l ->
+ class_type ~loc (List.map (sub.class_type_declaration sub) l)
+ | Psig_extension (x, attrs) ->
+ extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs)
+ | Psig_attribute x -> attribute ~loc (sub.attribute sub x)
+end
-val with_file_as_pp : string -> (Format.formatter -> 'a) -> 'a
-val is_pos_pow : Int32.t -> int
+module M = struct
+ (* Value expressions for the module language *)
-val failwithf : loc:string -> ('a, unit, string, 'b) format4 -> 'a
+ let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} =
+ let open Mod in
+ let loc = sub.location sub loc in
+ let attrs = sub.attributes sub attrs in
+ match desc with
+ | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x)
+ | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str)
+ | Pmod_functor (arg, arg_ty, body) ->
+ functor_ ~loc ~attrs (map_loc sub arg)
+ (Misc.may_map (sub.module_type sub) arg_ty)
+ (sub.module_expr sub body)
+ | Pmod_apply (m1, m2) ->
+ apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2)
+ | Pmod_constraint (m, mty) ->
+ constraint_ ~loc ~attrs (sub.module_expr sub m)
+ (sub.module_type sub mty)
+ | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e)
+ | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x)
-val invalid_argf : ('a, unit, string, 'b) format4 -> 'a
-
-val bad_argf : ('a, unit, string, 'b) format4 -> 'a
+ let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} =
+ let open Str in
+ let loc = sub.location sub loc in
+ match desc with
+ | Pstr_eval (x, attrs) ->
+ eval ~loc ~attrs:(sub.attributes sub attrs) (sub.expr sub x)
+ | Pstr_value (r, vbs) ->
+(* XXX *)
+(* value ~loc r (List.map (sub.value_binding sub) vbs) *)
+ value ~loc r
+ ((if r = Recursive then sub.value_bindings_rec else sub.value_bindings)
+ sub vbs)
+(* XXX *)
+ | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd)
+ | Pstr_type l -> type_ ~loc (List.map (sub.type_declaration sub) l)
+ | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te)
+ | Pstr_exception ed -> exception_ ~loc (sub.extension_constructor sub ed)
+ | Pstr_module x -> module_ ~loc (sub.module_binding sub x)
+ | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l)
+ | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x)
+ | Pstr_open x -> open_ ~loc (sub.open_description sub x)
+ | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l)
+ | Pstr_class_type l ->
+ class_type ~loc (List.map (sub.class_type_declaration sub) l)
+ | Pstr_include x -> include_ ~loc (sub.include_declaration sub x)
+ | Pstr_extension (x, attrs) ->
+ extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs)
+ | Pstr_attribute x -> attribute ~loc (sub.attribute sub x)
+end
+module E = struct
+ (* Value expressions for the core language *)
+ let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} =
+ let open Exp in
+ let loc = sub.location sub loc in
+ let attrs = sub.attributes sub attrs in
+ match desc with
+ | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x)
+ | Pexp_constant x -> constant ~loc ~attrs x
+ | Pexp_let (r, vbs, e) ->
+(* XXXX *)
+ (* let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs)
+ (sub.expr sub e) *)
+ let_ ~loc ~attrs r
+ (
+ (if r = Recursive then sub.value_bindings_rec else sub.value_bindings)
+ sub vbs
+ )
+ (sub.expr sub e)
+(* XXXX *)
+ | Pexp_fun (lab, def, p, e) ->
+ fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p)
+ (sub.expr sub e)
+ | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel)
+ | Pexp_apply (e, l) ->
+ apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l)
+ | Pexp_match (e, pel) ->
+ match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
+ | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
+ | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el)
+ | Pexp_construct (lid, arg) ->
+ construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg)
+ | Pexp_variant (lab, eo) ->
+ variant ~loc ~attrs lab (map_opt (sub.expr sub) eo)
+ | Pexp_record (l, eo) ->
+ record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l)
+ (map_opt (sub.expr sub) eo)
+ | Pexp_field (e, lid) ->
+ field ~loc ~attrs (sub.expr sub e) (map_loc sub lid)
+ | Pexp_setfield (e1, lid, e2) ->
+ setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid)
+ (sub.expr sub e2)
+ | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el)
+ | Pexp_ifthenelse (e1, e2, e3) ->
+ ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
+ (map_opt (sub.expr sub) e3)
+ | Pexp_sequence (e1, e2) ->
+ sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
+ | Pexp_while (e1, e2) ->
+ while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
+ | Pexp_for (p, e1, e2, d, e3) ->
+ for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d
+ (sub.expr sub e3)
+ | Pexp_coerce (e, t1, t2) ->
+ coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1)
+ (sub.typ sub t2)
+ | Pexp_constraint (e, t) ->
+ constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t)
+ | Pexp_send (e, s) -> send ~loc ~attrs (sub.expr sub e) s
+ | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid)
+ | Pexp_setinstvar (s, e) ->
+ setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e)
+ | Pexp_override sel ->
+ override ~loc ~attrs
+ (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel)
+ | Pexp_letmodule (s, me, e) ->
+ letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me)
+ (sub.expr sub e)
+ | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e)
+ | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e)
+ | Pexp_poly (e, t) ->
+ poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t)
+ | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls)
+ | Pexp_newtype (s, e) -> newtype ~loc ~attrs s (sub.expr sub e)
+ | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me)
+ | Pexp_open (ovf, lid, e) ->
+ open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e)
+ | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x)
+end
-val dump : 'a -> string
-val pp_any : Format.formatter -> 'a -> unit
-external id : 'a -> 'a = "%identity"
+module P = struct
+ (* Patterns *)
-(** Copied from {!Btype.hash_variant}:
- need sync up and add test case
- *)
-val hash_variant : string -> int
+ let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} =
+ let open Pat in
+ let loc = sub.location sub loc in
+ let attrs = sub.attributes sub attrs in
+ match desc with
+ | Ppat_any -> any ~loc ~attrs ()
+ | Ppat_var s -> var ~loc ~attrs (map_loc sub s)
+ | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s)
+ | Ppat_constant c -> constant ~loc ~attrs c
+ | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2
+ | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl)
+ | Ppat_construct (l, p) ->
+ construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p)
+ | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p)
+ | Ppat_record (lpl, cf) ->
+ record ~loc ~attrs
+ (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf
+ | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl)
+ | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2)
+ | Ppat_constraint (p, t) ->
+ constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t)
+ | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s)
+ | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p)
+ | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s)
+ | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p)
+ | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x)
+end
-end = struct
-#1 "ext_pervasives.ml"
-(* 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 CE = struct
+ (* Value expressions for the class language *)
+ let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} =
+ let open Cl in
+ let loc = sub.location sub loc in
+ let attrs = sub.attributes sub attrs in
+ match desc with
+ | Pcl_constr (lid, tys) ->
+ constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys)
+ | Pcl_structure s ->
+ structure ~loc ~attrs (sub.class_structure sub s)
+ | Pcl_fun (lab, e, p, ce) ->
+ fun_ ~loc ~attrs lab
+ (map_opt (sub.expr sub) e)
+ (sub.pat sub p)
+ (sub.class_expr sub ce)
+ | Pcl_apply (ce, l) ->
+ apply ~loc ~attrs (sub.class_expr sub ce)
+ (List.map (map_snd (sub.expr sub)) l)
+ | Pcl_let (r, vbs, ce) ->
+(* XXXX *)
+ (* let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs)
+ (sub.class_expr sub ce) *)
+ let_ ~loc ~attrs r
+ ((if r = Recursive then sub.value_bindings_rec else sub.value_bindings)
+ sub vbs)
+ (sub.class_expr sub ce)
+(* XXXX *)
+ | Pcl_constraint (ce, ct) ->
+ constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct)
+ | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x)
+ let map_kind sub = function
+ | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e)
+ | Cfk_virtual t -> Cfk_virtual (sub.typ sub t)
+ let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} =
+ let open Cf in
+ let loc = sub.location sub loc in
+ let attrs = sub.attributes sub attrs in
+ match desc with
+ | Pcf_inherit (o, ce, s) -> inherit_ ~loc ~attrs o (sub.class_expr sub ce) s
+ | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k)
+ | Pcf_method (s, p, k) ->
+ method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k)
+ | Pcf_constraint (t1, t2) ->
+ constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2)
+ | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e)
+ | Pcf_attribute x -> attribute ~loc (sub.attribute sub x)
+ | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x)
+ let map_structure sub {pcstr_self; pcstr_fields} =
+ {
+ pcstr_self = sub.pat sub pcstr_self;
+ pcstr_fields = List.map (sub.class_field sub) pcstr_fields;
+ }
+ let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr;
+ pci_loc; pci_attributes} =
+ Ci.mk
+ ~virt:pci_virt
+ ~params:(List.map (map_fst (sub.typ sub)) pl)
+ (map_loc sub pci_name)
+ (f pci_expr)
+ ~loc:(sub.location sub pci_loc)
+ ~attrs:(sub.attributes sub pci_attributes)
+end
-external reraise: exn -> 'a = "%reraise"
+(* Now, a generic AST mapper, to be extended to cover all kinds and
+ cases of the OCaml grammar. The default behavior of the mapper is
+ the identity. *)
-let finally v action f =
- match f v with
- | exception e ->
- action v ;
- reraise e
- | e -> action v ; e
+let default_mapper =
+ {
+ structure = (fun this l -> List.map (this.structure_item this) l);
+ structure_item = M.map_structure_item;
+ module_expr = M.map;
+ signature = (fun this l -> List.map (this.signature_item this) l);
+ signature_item = MT.map_signature_item;
+ module_type = MT.map;
+ with_constraint = MT.map_with_constraint;
+ class_declaration =
+ (fun this -> CE.class_infos this (this.class_expr this));
+ class_expr = CE.map;
+ class_field = CE.map_field;
+ class_structure = CE.map_structure;
+ class_type = CT.map;
+ class_type_field = CT.map_field;
+ class_signature = CT.map_signature;
+ class_type_declaration =
+ (fun this -> CE.class_infos this (this.class_type this));
+ class_description =
+ (fun this -> CE.class_infos this (this.class_type this));
+ type_declaration = T.map_type_declaration;
+ type_kind = T.map_type_kind;
+ typ = T.map;
+ type_extension = T.map_type_extension;
+ extension_constructor = T.map_extension_constructor;
+ value_description =
+ (fun this {pval_name; pval_type; pval_prim; pval_loc;
+ pval_attributes} ->
+ Val.mk
+ (map_loc this pval_name)
+ (this.typ this pval_type)
+ ~attrs:(this.attributes this pval_attributes)
+ ~loc:(this.location this pval_loc)
+ ~prim:pval_prim
+ );
-let with_file_as_chan filename f =
- finally (open_out_bin filename) close_out f
+ pat = P.map;
+ expr = E.map;
-let with_file_as_pp filename f =
- finally (open_out_bin filename) close_out
- (fun chan ->
- let fmt = Format.formatter_of_out_channel chan in
+ module_declaration =
+ (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} ->
+ Md.mk
+ (map_loc this pmd_name)
+ (this.module_type this pmd_type)
+ ~attrs:(this.attributes this pmd_attributes)
+ ~loc:(this.location this pmd_loc)
+ );
+
+ module_type_declaration =
+ (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} ->
+ Mtd.mk
+ (map_loc this pmtd_name)
+ ?typ:(map_opt (this.module_type this) pmtd_type)
+ ~attrs:(this.attributes this pmtd_attributes)
+ ~loc:(this.location this pmtd_loc)
+ );
+
+ module_binding =
+ (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} ->
+ Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr)
+ ~attrs:(this.attributes this pmb_attributes)
+ ~loc:(this.location this pmb_loc)
+ );
+
+
+ open_description =
+ (fun this {popen_lid; popen_override; popen_attributes; popen_loc} ->
+ Opn.mk (map_loc this popen_lid)
+ ~override:popen_override
+ ~loc:(this.location this popen_loc)
+ ~attrs:(this.attributes this popen_attributes)
+ );
+
+
+ include_description =
+ (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
+ Incl.mk (this.module_type this pincl_mod)
+ ~loc:(this.location this pincl_loc)
+ ~attrs:(this.attributes this pincl_attributes)
+ );
+
+ include_declaration =
+ (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
+ Incl.mk (this.module_expr this pincl_mod)
+ ~loc:(this.location this pincl_loc)
+ ~attrs:(this.attributes this pincl_attributes)
+ );
+
+ value_bindings = (fun this vbs ->
+ match vbs with
+ | [vb] -> [ this.value_binding this vb ]
+ | _ -> List.map (this.value_binding this) vbs
+ );
+ value_bindings_rec = (fun this vbs ->
+ match vbs with
+ | [vb] -> [ this.value_binding this vb ]
+ | _ -> List.map (this.value_binding this) vbs
+ );
+ value_binding =
+ (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} ->
+ Vb.mk
+ (this.pat this pvb_pat)
+ (this.expr this pvb_expr)
+ ~loc:(this.location this pvb_loc)
+ ~attrs:(this.attributes this pvb_attributes)
+ );
+
+
+ constructor_declaration =
+ (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} ->
+ Type.constructor
+ (map_loc this pcd_name)
+ ~args:(List.map (this.typ this) pcd_args)
+ ?res:(map_opt (this.typ this) pcd_res)
+ ~loc:(this.location this pcd_loc)
+ ~attrs:(this.attributes this pcd_attributes)
+ );
+
+ label_declaration =
+ (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} ->
+ Type.field
+ (map_loc this pld_name)
+ (this.typ this pld_type)
+ ~mut:pld_mutable
+ ~loc:(this.location this pld_loc)
+ ~attrs:(this.attributes this pld_attributes)
+ );
+
+ cases = (fun this l -> List.map (this.case this) l);
+ case =
+ (fun this {pc_lhs; pc_guard; pc_rhs} ->
+ {
+ pc_lhs = this.pat this pc_lhs;
+ pc_guard = map_opt (this.expr this) pc_guard;
+ pc_rhs = this.expr this pc_rhs;
+ }
+ );
+
+
+
+ location = (fun this l -> l);
+
+ extension = (fun this (s, e) -> (map_loc this s, this.payload this e));
+ attribute = (fun this (s, e) -> (map_loc this s, this.payload this e));
+ attributes = (fun this l -> List.map (this.attribute this) l);
+ payload =
+ (fun this -> function
+ | PStr x -> PStr (this.structure this x)
+ | PTyp x -> PTyp (this.typ this x)
+ | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g)
+ );
+ }
+end
+module Ext_pervasives : sig
+#1 "ext_pervasives.mli"
+(* 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. *)
+
+
+
+
+
+
+
+
+(** Extension to standard library [Pervavives] module, safe to open
+ *)
+
+external reraise: exn -> 'a = "%reraise"
+
+val finally : 'a -> ('a -> 'c) -> ('a -> 'b) -> 'b
+
+val with_file_as_chan : string -> (out_channel -> 'a) -> 'a
+
+val with_file_as_pp : string -> (Format.formatter -> 'a) -> 'a
+
+val is_pos_pow : Int32.t -> int
+
+val failwithf : loc:string -> ('a, unit, string, 'b) format4 -> 'a
+
+val invalid_argf : ('a, unit, string, 'b) format4 -> 'a
+
+val bad_argf : ('a, unit, string, 'b) format4 -> 'a
+
+
+
+val dump : 'a -> string
+val pp_any : Format.formatter -> 'a -> unit
+external id : 'a -> 'a = "%identity"
+
+(** Copied from {!Btype.hash_variant}:
+ need sync up and add test case
+ *)
+val hash_variant : string -> int
+
+end = struct
+#1 "ext_pervasives.ml"
+(* 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. *)
+
+
+
+
+
+
+external reraise: exn -> 'a = "%reraise"
+
+let finally v action f =
+ match f v with
+ | exception e ->
+ action v ;
+ reraise e
+ | e -> action v ; e
+
+let with_file_as_chan filename f =
+ finally (open_out_bin filename) close_out f
+
+let with_file_as_pp filename f =
+ finally (open_out_bin filename) close_out
+ (fun chan ->
+ let fmt = Format.formatter_of_out_channel chan in
let v = f fmt in
Format.pp_print_flush fmt ();
v
@@ -31090,9 +31502,9 @@ let is_enum_constructors
)
constructors
end
-module Ast_derive_js_mapper : sig
-#1 "ast_derive_js_mapper.mli"
-(* Copyright (C) 2017 Authors of BuckleScript
+module Bs_loc : sig
+#1 "bs_loc.mli"
+(* 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
@@ -31116,12 +31528,20 @@ module Ast_derive_js_mapper : sig
* 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 = Location.t = {
+ loc_start : Lexing.position;
+ loc_end : Lexing.position ;
+ loc_ghost : bool
+}
+
+val is_ghost : t -> bool
+val merge : t -> t -> t
+val none : t
-val init : unit -> unit
end = struct
-#1 "ast_derive_js_mapper.ml"
-(* Copyright (C) 2017 Authors of BuckleScript
+#1 "bs_loc.ml"
+(* 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
@@ -31145,649 +31565,166 @@ end = struct
* 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 U = Ast_derive_util
-type tdcls = Parsetree.type_declaration list
-let js_field (o : Parsetree.expression) m =
- Exp.apply
- (Exp.ident {txt = Lident "##"; loc = o.pexp_loc})
- [
- "",o;
- "", Exp.ident m
- ]
-let const_int i = Exp.constant (Const_int i)
-let const_string s = Exp.constant (Const_string (s,None))
+type t = Location.t = {
+ loc_start : Lexing.position;
+ loc_end : Lexing.position ;
+ loc_ghost : bool
+}
+let is_ghost x = x.loc_ghost
-let handle_config (config : Parsetree.expression option) =
- match config with
- | Some config ->
- (match config.pexp_desc with
- | Pexp_record (
- [
- {txt = Lident "newType"},
- {pexp_desc =
- (Pexp_construct
- (
- {txt =
- Lident ("true"
- | "false"
- as x)}, None)
- | Pexp_ident {txt = Lident ("newType" as x)}
- )
- }
- ],None)
- -> not (x = "false")
- | Pexp_ident {txt = Lident ("newType")}
- -> true
- | _ -> U.invalid_config config)
- | None -> false
-let noloc = Location.none
-(* [eraseType] will be instrumented, be careful about the name conflict*)
-let eraseTypeLit = "jsMapperEraseType"
-let eraseTypeExp = Exp.ident {loc = noloc; txt = Lident eraseTypeLit}
-let eraseType x =
- Exp.apply eraseTypeExp ["", x]
-let eraseTypeStr =
- let any = Typ.any () in
- Str.primitive
- (Val.mk ~prim:["%identity"] {loc = noloc; txt = eraseTypeLit}
- (Typ.arrow "" any any)
- )
+let merge (l: t) (r : t) =
+ if is_ghost l then r
+ else if is_ghost r then l
+ else match l,r with
+ | {loc_start ; }, {loc_end; _} (* TODO: improve*)
+ ->
+ {loc_start ;loc_end; loc_ghost = false}
-let app2 f arg1 arg2 =
- Exp.apply f ["",arg1; "", arg2]
-let app3 f arg1 arg2 arg3 =
- Exp.apply f ["", arg1; "", arg2; "", arg3]
-let (<=~) a b =
- app2 (Exp.ident {loc = noloc; txt = Lident "<="}) a b
-let (-~) a b =
- app2 (Exp.ident {loc = noloc; txt = Ldot(Lident "Pervasives","-")})
- a b
-let (+~) a b =
- app2 (Exp.ident {loc = noloc; txt = Ldot(Lident "Pervasives","+")})
- a b
-let (&&~) a b =
- app2 (Exp.ident {loc = noloc; txt = Ldot(Lident "Pervasives","&&")})
- a b
-let (->~) a b = Typ.arrow "" a b
-let jsMapperRt =
- Longident.Ldot (Lident "Js", "MapperRt")
+let none = Location.none
-let search upper polyvar array =
- app3
- (Exp.ident ({loc = noloc;
- txt = Longident.Ldot (jsMapperRt,"binarySearch") })
- )
- upper
- (eraseType polyvar)
- array
+end
+module External_ffi_types : sig
+#1 "external_ffi_types.mli"
+(* 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 revSearch len constantArray exp =
- app3
- (Exp.ident
- {loc= noloc;
- txt = Longident.Ldot (jsMapperRt, "revSearch")})
- len
- constantArray
- exp
+type module_bind_name =
+ | Phint_name of string
+ (* explicit hint name *)
+ | Phint_nothing
-let revSearchAssert len constantArray exp =
- app3
- (Exp.ident
- {loc= noloc;
- txt = Longident.Ldot (jsMapperRt, "revSearchAssert")})
- len
- constantArray
- exp
+type external_module_name =
+ { bundle : string ;
+ module_bind_name : module_bind_name
+ }
-let toInt exp array =
- app2
- (Exp.ident
- { loc=noloc;
- txt = Longident.Ldot (jsMapperRt, "toInt")})
- (eraseType exp)
- array
-let fromInt len array exp =
- app3
- (Exp.ident
- {loc = noloc;
- txt = Longident.Ldot (jsMapperRt,"fromInt")})
- len
- array
- exp
+type pipe = bool
+type js_call = {
+ name : string;
+ external_module_name : external_module_name option;
+ splice : bool ;
+ scopes : string list
+}
-let fromIntAssert len array exp =
- app3
- (Exp.ident
- {loc = noloc;
- txt = Longident.Ldot (jsMapperRt,"fromIntAssert")})
- len
- array
- exp
+type js_send = {
+ name : string ;
+ splice : bool ;
+ pipe : pipe ;
+ js_send_scopes : string list;
+} (* we know it is a js send, but what will happen if you pass an ocaml objct *)
+type js_global_val = {
+ name : string ;
+ external_module_name : external_module_name option;
+ scopes : string list
+}
-let assertExp e =
- Exp.extension
- ({Asttypes.loc = noloc; txt = "assert"},
- (PStr
- [Str.eval e ]
- )
- )
-let derivingName = "jsConverter"
+type js_new_val = {
+ name : string ;
+ external_module_name : external_module_name option;
+ splice : bool ;
+ scopes : string list;
+}
-(* let notApplicable loc =
- Location.prerr_warning
- loc
- (Warnings.Bs_derive_warning ( derivingName ^ " not applicable to this type")) *)
+type js_module_as_fn =
+ { external_module_name : external_module_name;
+ splice : bool
+ }
-let init () =
- Ast_derive.register
- derivingName
- (fun ( x : Parsetree.expression option) ->
- let createType = handle_config x in
+type arg_type = External_arg_spec.attr
- {
- structure_gen = (fun (tdcls : tdcls) _ ->
- let handle_tdcl (tdcl: Parsetree.type_declaration) =
- let core_type = U.core_type_of_type_declaration tdcl
- in
- let name = tdcl.ptype_name.txt in
- let toJs = name ^ "ToJs" in
- let fromJs = name ^ "FromJs" in
- let constantArray = "jsMapperConstantArray" in
- let loc = tdcl.ptype_loc in
- let patToJs = {Asttypes.loc; txt = toJs} in
- let patFromJs = {Asttypes.loc; txt = fromJs} in
- let param = "param" in
+type arg_label = External_arg_spec.label
- let ident_param = {Asttypes.txt = Longident.Lident param; loc} in
- let pat_param = {Asttypes.loc; txt = param} in
- let exp_param = Exp.ident ident_param in
- let newType,newTdcl =
- U.new_type_of_type_declaration tdcl ("abs_" ^ name) in
- let newTypeStr = Str.type_ [newTdcl] in
- let toJsBody body =
- Ast_comb.single_non_rec_value patToJs
- (Exp.fun_ "" None (Pat.constraint_ (Pat.var pat_param) core_type)
- body )
- in
- let (+>) a ty =
- Exp.constraint_ (eraseType a) ty in
- let (+:) a ty =
- eraseType (Exp.constraint_ a ty) in
- let coerceResultToNewType e =
- if createType then
- e +> newType
- else e
- in
- match tdcl.ptype_kind with
- | Ptype_record label_declarations ->
- let exp =
- coerceResultToNewType
- (Exp.extension
- (
- {Asttypes.loc; txt = "bs.obj"},
- (PStr
- [Str.eval
- (Exp.record
- (List.map
- (fun ({pld_name = {loc; txt } } : Parsetree.label_declaration) ->
- let label =
- {Asttypes.loc; txt = Longident.Lident txt } in
- label,Exp.field exp_param label
- ) label_declarations) None)]))) in
- let toJs =
- toJsBody exp
- in
- let obj_exp =
- Exp.record
- (List.map
- (fun ({pld_name = {loc; txt } } : Parsetree.label_declaration) ->
- let label =
- {Asttypes.loc; txt = Longident.Lident txt } in
- label,
- js_field exp_param label
- ) label_declarations) None in
- let fromJs =
- Ast_comb.single_non_rec_value patFromJs
- (Exp.fun_ "" None (Pat.var pat_param)
- (if createType then
- (Exp.let_ Nonrecursive
- [Vb.mk
- (Pat.var pat_param)
- (exp_param +: newType)]
- (Exp.constraint_ obj_exp core_type) )
- else
- (Exp.constraint_ obj_exp core_type) ))
- in
- let rest =
- [
- toJs;
- fromJs
- ] in
- if createType then eraseTypeStr:: newTypeStr :: rest else rest
- | Ptype_abstract ->
- (match Ast_polyvar.is_enum_polyvar tdcl with
- | Some row_fields ->
- let attr =
- Ast_polyvar.map_row_fields_into_strings loc row_fields
- in
- let expConstantArray =
- Exp.ident {loc; txt = Longident.Lident constantArray} in
- begin match attr with
- | NullString result ->
- let result_len = List.length result in
- let exp_len = const_int result_len in
- let v = [
- eraseTypeStr;
- Ast_comb.single_non_rec_value
- {loc; txt = constantArray}
- (Exp.array
- (List.map (fun (i,str) ->
- Exp.tuple
- [
- const_int i;
- const_string str
- ]
- ) (List.sort (fun (a,_) (b,_) -> compare (a:int) b) result)));
- (
- toJsBody
- (coerceResultToNewType
- (search
- exp_len
- exp_param
- expConstantArray
- ))
- );
- Ast_comb.single_non_rec_value
- patFromJs
- (Exp.fun_ "" None
- (Pat.var pat_param)
- (if createType then
- revSearchAssert
- exp_len
- expConstantArray
- (exp_param +: newType)
- +>
- core_type
- else
- revSearch
- exp_len
- expConstantArray
- exp_param
- +>
- Ast_core_type.lift_option_type core_type
- )
- )
- ] in
- if createType then
- newTypeStr :: v
- else v
- | _ -> assert false
- end
- | None ->
- U.notApplicable
- tdcl.Parsetree.ptype_loc
- derivingName;
- []
- )
- | Ptype_variant ctors ->
- if Ast_polyvar.is_enum_constructors ctors then
- let xs = Ast_polyvar.map_constructor_declarations_into_ints ctors in
- match xs with
- | `New xs ->
- let constantArrayExp = Exp.ident {loc; txt = Lident constantArray} in
- let exp_len = const_int (List.length ctors) in
- let v = [
- eraseTypeStr;
- Ast_comb.single_non_rec_value
- {loc; txt = constantArray}
- (Exp.array (List.map (fun i -> const_int i) xs ))
- ;
- toJsBody
- (
- coerceResultToNewType @@
- toInt
- exp_param
- constantArrayExp
- )
- ;
- Ast_comb.single_non_rec_value
- patFromJs
- (Exp.fun_ "" None
- (Pat.var pat_param)
- (
- if createType then
- fromIntAssert
- exp_len
- constantArrayExp
- (exp_param +: newType)
- +>
- core_type
- else
- fromInt
- exp_len
- constantArrayExp
- exp_param
- +>
- Ast_core_type.lift_option_type core_type
+type obj_create = External_arg_spec.t list
- )
- )
- ] in
- if createType then newTypeStr :: v else v
- | `Offset offset ->
- let v =
- [ eraseTypeStr;
- toJsBody (
- coerceResultToNewType
- (eraseType exp_param +~ const_int offset)
- )
- ;
- let len = List.length ctors in
- let range_low = const_int (offset + 0) in
- let range_upper = const_int (offset + len - 1) in
+type js_get =
+ { js_get_name : string ;
+ js_get_scopes : string list;
+ }
- Ast_comb.single_non_rec_value
- {loc ; txt = fromJs}
- (Exp.fun_ "" None
- (Pat.var pat_param)
- (if createType then
- (Exp.let_ Nonrecursive
- [Vb.mk
- (Pat.var pat_param)
- (exp_param +: newType)
- ]
- (
- Exp.sequence
- (assertExp
- ((exp_param <=~ range_upper) &&~ (range_low <=~ exp_param))
- )
- (exp_param -~ const_int offset))
- )
- +>
- core_type
- else
- (Exp.ifthenelse
- ( (exp_param <=~ range_upper) &&~ (range_low <=~ exp_param))
- (Exp.construct {loc; txt = Lident "Some"}
- ( Some (exp_param -~ const_int offset)))
- (Some (Exp.construct {loc; txt = Lident "None"} None)))
- +>
- Ast_core_type.lift_option_type core_type
- )
- )
- ] in
- if createType then newTypeStr :: v else v
- else
- begin
- U.notApplicable
- tdcl.Parsetree.ptype_loc
- derivingName;
- []
- end
- | Ptype_open ->
- U.notApplicable tdcl.Parsetree.ptype_loc
- derivingName;
- [] in
- Ext_list.flat_map handle_tdcl tdcls
- );
- signature_gen =
- (fun (tdcls : tdcls) _ ->
- let handle_tdcl tdcl =
- let core_type = U.core_type_of_type_declaration tdcl
- in
- let name = tdcl.ptype_name.txt in
- let toJs = name ^ "ToJs" in
- let fromJs = name ^ "FromJs" in
- let loc = tdcl.ptype_loc in
- let patToJs = {Asttypes.loc; txt = toJs} in
- let patFromJs = {Asttypes.loc; txt = fromJs} in
- let toJsType result =
- Ast_comb.single_non_rec_val patToJs (Typ.arrow "" core_type result) in
- let newType,newTdcl =
- U.new_type_of_type_declaration tdcl ("abs_" ^ name) in
- let newTypeStr = Sig.type_ [newTdcl] in
- let (+?) v rest = if createType then v :: rest else rest in
- match tdcl.ptype_kind with
- | Ptype_record label_declarations ->
+type js_set =
+ { js_set_name : string ;
+ js_set_scopes : string list
+ }
- let objType flag =
- Ast_comb.to_js_type loc @@
- Typ.object_
- (List.map
- (fun ({pld_name = {loc; txt }; pld_type } : Parsetree.label_declaration) ->
- txt, [], pld_type
- ) label_declarations)
- flag in
- newTypeStr +?
- [
- toJsType (if createType then newType else objType Closed);
- Ast_comb.single_non_rec_val patFromJs
- ( (if createType then newType else objType Open)->~ core_type)
- ]
- | Ptype_abstract ->
- (match Ast_polyvar.is_enum_polyvar tdcl with
- | Some _ ->
- let ty1 =
- if createType then newType else
- (Ast_literal.type_string ()) in
- let ty2 =
- if createType then core_type
- else Ast_core_type.lift_option_type core_type in
- newTypeStr +?
- [
- toJsType ty1;
- Ast_comb.single_non_rec_val
- patFromJs
- (ty1 ->~ ty2)
- ]
+type js_get_index = {
+ js_get_index_scopes : string list
+}
- | None ->
- U.notApplicable tdcl.Parsetree.ptype_loc
- derivingName;
- [])
+type js_set_index = {
+ js_set_index_scopes : string list
+}
- | Ptype_variant ctors
- ->
-
- if Ast_polyvar.is_enum_constructors ctors then
- let ty1 =
- if createType then newType
- else Ast_literal.type_int() in
- let ty2 =
- if createType then core_type
- else Ast_core_type.lift_option_type core_type in
- newTypeStr +?
- [
- toJsType ty1;
- Ast_comb.single_non_rec_val
- patFromJs
- (ty1 ->~ ty2)
- ]
-
- else
- begin
- U.notApplicable tdcl.Parsetree.ptype_loc
- derivingName;
- []
- end
- | Ptype_open ->
- U.notApplicable tdcl.Parsetree.ptype_loc
- derivingName;
- [] in
- Ext_list.flat_map handle_tdcl tdcls
-
- );
- expression_gen = None
- }
- )
-;
-
-end
-module Ast_derive_projector : sig
-#1 "ast_derive_projector.mli"
-(* Copyright (C) 2017 Authors of BuckleScript
- *
- * 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 attr =
+ | Js_global of js_global_val
+ | Js_module_as_var of external_module_name
+ | Js_module_as_fn of js_module_as_fn
+ | Js_module_as_class of external_module_name
+ | Js_call of js_call
+ | Js_send of js_send
+ | Js_new of js_new_val
+ | Js_set of js_set
+ | Js_get of js_get
+ | Js_get_index of js_get_index
+ | Js_set_index of js_set_index
-val init : unit -> unit
-
-end = struct
-#1 "ast_derive_projector.ml"
-open Ast_helper
-
-let invalid_config (config : Parsetree.expression) =
- Location.raise_errorf ~loc:config.pexp_loc "such configuration is not supported"
-
+type return_wrapper =
+ | Return_unset
+ | Return_identity
+ | Return_undefined_to_opt
+ | Return_null_to_opt
+ | Return_null_undefined_to_opt
+ | Return_to_ocaml_bool
+ | Return_replaced_with_unit
+type t =
+ | Ffi_bs of
+ External_arg_spec.t list *
+ return_wrapper * attr
+ | Ffi_obj_create of obj_create
+ | Ffi_normal
+ (* When it's normal, it is handled as normal c functional ffi call *)
-type tdcls = Parsetree.type_declaration list
-let derivingName = "accessors"
-let init () =
-
- Ast_derive.register
- derivingName
- (fun (x : Parsetree.expression option) ->
- (match x with
- | Some config -> invalid_config config
- | None -> ());
- {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
- ->
- label_declarations
- |> Ext_list.map (
- 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
- (Exp.fun_ "" None
- (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
- ->
- constructor_declarations
- |> Ext_list.map
- (fun
- ( {pcd_name = {loc ; txt = con_name} ; pcd_args ; pcd_loc }:
- Parsetree.constructor_declaration)
- -> (* TODO: add type annotations *)
- let little_con_name = String.uncapitalize con_name in
- let arity = List.length pcd_args 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)
- core_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 = Longident.Lident (List.hd vars )}
- else
- Exp.tuple (Ext_list.map
- (fun x -> Exp.ident {loc ; txt = Longident.Lident x})
- vars
- ) )) core_type
- in
- Ext_list.fold_right (fun var b ->
- Exp.fun_ "" None (Pat.var {loc ; txt = var}) b
- ) vars exp
+val name_of_ffi : attr -> string
- 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 handle_tdcl tdcls
+val check_ffi : ?loc:Location.t -> attr -> unit
+val to_string : t -> string
- 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
- ->
- label_declarations
- |> Ext_list.map
- (fun
- ({pld_name ;
- pld_type
- } :
- Parsetree.label_declaration) ->
- Ast_comb.single_non_rec_val pld_name (Typ.arrow "" core_type pld_type )
- )
- | Ptype_variant constructor_declarations
- ->
- constructor_declarations
- |>
- Ext_list.map
- (fun ({pcd_name = {loc ; txt = con_name} ; pcd_args ; pcd_loc }:
- Parsetree.constructor_declaration)
- ->
- Ast_comb.single_non_rec_val {loc ; txt = (String.uncapitalize con_name)}
- (Ext_list.fold_right
- (fun x acc -> Typ.arrow "" x acc)
- pcd_args
- core_type))
- | Ptype_open | Ptype_abstract ->
- Ast_derive_util.notApplicable tdcl.ptype_loc derivingName ;
- []
- in
- Ext_list.flat_map handle_tdcl tdcls
- end;
- expression_gen = None
- }
- )
+(** Note *)
+val from_string : string -> t
-end
-module Ext_char : sig
-#1 "ext_char.mli"
+end = struct
+#1 "external_ffi_types.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -31812,21 +31749,270 @@ module Ext_char : sig
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
+type module_bind_name =
+ | Phint_name of string
+ (* explicit hint name *)
+ | Phint_nothing
+
+type external_module_name =
+ { bundle : string ;
+ module_bind_name : module_bind_name
+ }
+type pipe = bool
+type js_call = {
+ name : string;
+ external_module_name : external_module_name option;
+ splice : bool ;
+ scopes : string list ;
+}
+type js_send = {
+ name : string ;
+ splice : bool ;
+ pipe : pipe ;
+ js_send_scopes : string list;
+} (* we know it is a js send, but what will happen if you pass an ocaml objct *)
-(** Extension to Standard char module, avoid locale sensitivity *)
-
-val escaped : char -> string
+type js_global_val = {
+ name : string ;
+ external_module_name : external_module_name option;
+ scopes : string list ;
+}
+type js_new_val = {
+ name : string ;
+ external_module_name : external_module_name option;
+ splice : bool ;
+ scopes : string list;
+}
-val valid_hex : char -> bool
+type js_module_as_fn =
+ { external_module_name : external_module_name;
+ splice : bool ;
-val is_lower_case : char -> bool
-end = struct
-#1 "ext_char.ml"
+ }
+type js_get =
+ { js_get_name : string ;
+ js_get_scopes : string list;
+ }
+
+type js_set =
+ { js_set_name : string ;
+ js_set_scopes : string list
+ }
+
+type js_get_index = {
+ js_get_index_scopes : string list
+}
+
+type js_set_index = {
+ js_set_index_scopes : string list
+}
+(** TODO: information between [arg_type] and [arg_label] are duplicated,
+ design a more compact representation so that it is also easy to seralize by hand
+*)
+type arg_type = External_arg_spec.attr
+
+type arg_label = External_arg_spec.label
+
+
+(**TODO: maybe we can merge [arg_label] and [arg_type] *)
+type obj_create = External_arg_spec.t list
+
+type attr =
+ | Js_global of js_global_val
+ | Js_module_as_var of external_module_name
+ | Js_module_as_fn of js_module_as_fn
+ | Js_module_as_class of external_module_name
+ | Js_call of js_call
+ | Js_send of js_send
+ | Js_new of js_new_val
+ | Js_set of js_set
+ | Js_get of js_get
+ | Js_get_index of js_get_index
+ | Js_set_index of js_set_index
+
+let name_of_ffi ffi =
+ match ffi with
+ | Js_get_index _scope -> "[@@bs.get_index ..]"
+ | Js_set_index _scope -> "[@@bs.set_index ..]"
+ | Js_get { js_get_name = s} -> Printf.sprintf "[@@bs.get %S]" s
+ | Js_set { js_set_name = s} -> Printf.sprintf "[@@bs.set %S]" s
+ | Js_call v -> Printf.sprintf "[@@bs.val %S]" v.name
+ | Js_send v -> Printf.sprintf "[@@bs.send %S]" v.name
+ | Js_module_as_fn v -> Printf.sprintf "[@@bs.val %S]" v.external_module_name.bundle
+ | Js_new v -> Printf.sprintf "[@@bs.new %S]" v.name
+ | Js_module_as_class v
+ -> Printf.sprintf "[@@bs.module] %S " v.bundle
+ | Js_module_as_var v
+ ->
+ Printf.sprintf "[@@bs.module] %S " v.bundle
+ | Js_global v
+ ->
+ Printf.sprintf "[@@bs.val] %S " v.name
+
+type return_wrapper =
+ | Return_unset
+ | Return_identity
+ | Return_undefined_to_opt
+ | Return_null_to_opt
+ | Return_null_undefined_to_opt
+ | Return_to_ocaml_bool
+ | Return_replaced_with_unit
+type t =
+ | Ffi_bs of External_arg_spec.t list *
+ return_wrapper * attr
+ (** [Ffi_bs(args,return,attr) ]
+ [return] means return value is unit or not,
+ [true] means is [unit]
+ *)
+ | Ffi_obj_create of obj_create
+ | Ffi_normal
+ (* When it's normal, it is handled as normal c functional ffi call *)
+
+
+
+let valid_js_char =
+ let a = Array.init 256 (fun i ->
+ let c = Char.chr i in
+ (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || (c >= '0' && c <= '9') || c = '_' || c = '$'
+ ) in
+ (fun c -> Array.unsafe_get a (Char.code c))
+
+let valid_first_js_char =
+ let a = Array.init 256 (fun i ->
+ let c = Char.chr i in
+ (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || c = '_' || c = '$'
+ ) in
+ (fun c -> Array.unsafe_get a (Char.code c))
+
+(** Approximation could be improved *)
+let valid_ident (s : string) =
+ let len = String.length s in
+ len > 0 && valid_js_char s.[0] && valid_first_js_char s.[0] &&
+ (let module E = struct exception E end in
+ try
+ for i = 1 to len - 1 do
+ if not (valid_js_char (String.unsafe_get s i)) then
+ raise E.E
+ done ;
+ true
+ with E.E -> false )
+
+let valid_global_name ?loc txt =
+ if not (valid_ident txt) then
+ let v = Ext_string.split_by ~keep_empty:true (fun x -> x = '.') txt in
+ List.iter
+ (fun s ->
+ if not (valid_ident s) then
+ Location.raise_errorf ?loc "Not a valid global name %s" txt
+ ) v
+
+let valid_method_name ?loc txt =
+ if not (valid_ident txt) then
+ Location.raise_errorf ?loc "Not a valid method name %s" txt
+
+
+
+let check_external_module_name ?loc x =
+ match x with
+ | {bundle = ""; _ }
+ | { module_bind_name = Phint_name "" } ->
+ Location.raise_errorf ?loc "empty name encountered"
+ | _ -> ()
+let check_external_module_name_opt ?loc x =
+ match x with
+ | None -> ()
+ | Some v -> check_external_module_name ?loc v
+
+
+let check_ffi ?loc ffi =
+ match ffi with
+ | Js_global {name} -> valid_global_name ?loc name
+ | Js_send {name }
+ | Js_set {js_set_name = name}
+ | Js_get { js_get_name = name}
+ -> valid_method_name ?loc name
+ | Js_get_index _ (* TODO: check scopes *)
+ | Js_set_index _
+ -> ()
+
+ | Js_module_as_var external_module_name
+ | Js_module_as_fn {external_module_name; _}
+ | Js_module_as_class external_module_name
+ -> check_external_module_name external_module_name
+ | Js_new {external_module_name ; name}
+ | Js_call {external_module_name ; name ; _}
+ ->
+ check_external_module_name_opt ?loc external_module_name ;
+ valid_global_name ?loc name
+
+let bs_prefix = "BS:"
+let bs_prefix_length = String.length bs_prefix
+
+
+(** TODO: Make sure each version is not prefix of each other
+ Solution:
+ 1. fixed length
+ 2. non-prefix approach
+*)
+let bs_external = bs_prefix ^ Bs_version.version
+
+
+let bs_external_length = String.length bs_external
+
+
+let to_string t =
+ bs_external ^ Marshal.to_string t []
+
+
+(* TODO: better error message when version mismatch *)
+let from_string s : t =
+ let s_len = String.length s in
+ if s_len >= bs_prefix_length &&
+ String.unsafe_get s 0 = 'B' &&
+ String.unsafe_get s 1 = 'S' &&
+ String.unsafe_get s 2 = ':' then
+ if Ext_string.starts_with s bs_external then
+ Marshal.from_string s bs_external_length
+ else
+ Ext_pervasives.failwithf
+ ~loc:__LOC__
+ "Compiler version mismatch. The project might have been built with one version of BuckleScript, and then with another. Please wipe the artifacts and do a clean build."
+ else Ffi_normal
+
+end
+module Bs_hash_stubs
+= struct
+#1 "bs_hash_stubs.ml"
+
+
+external hash_string : string -> int = "caml_bs_hash_string" "noalloc";;
+
+external hash_string_int : string -> int -> int = "caml_bs_hash_string_and_int" "noalloc";;
+
+external hash_string_small_int : string -> int -> int = "caml_bs_hash_string_and_small_int" "noalloc";;
+
+external hash_stamp_and_name : int -> string -> int = "caml_bs_hash_stamp_and_name" "noalloc";;
+
+external hash_small_int : int -> int = "caml_bs_hash_small_int" "noalloc";;
+
+external hash_int : int -> int = "caml_bs_hash_int" "noalloc";;
+
+external string_length_based_compare : string -> string -> int = "caml_string_length_based_compare" "noalloc";;
+
+
+external
+ int_unsafe_blit :
+ int array -> int -> int array -> int -> int -> unit = "caml_int_array_blit" "noalloc";;
+
+
+end
+module String_hash_set : sig
+#1 "string_hash_set.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -31852,58 +32038,107 @@ end = struct
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
+include Hash_set_gen.S with type key = string
+end = struct
+#1 "string_hash_set.ml"
+# 1 "ext/hash_set.cppo.ml"
+(* 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. *)
+# 31
+type key = string
+let key_index (h : _ Hash_set_gen.t ) (key : key) =
+ (Bs_hash_stubs.hash_string key) land (Array.length h.data - 1)
+let eq_key = Ext_string.equal
+type t = key Hash_set_gen.t
+# 62
+let create = Hash_set_gen.create
+let clear = Hash_set_gen.clear
+let reset = Hash_set_gen.reset
+let copy = Hash_set_gen.copy
+let iter = Hash_set_gen.iter
+let fold = Hash_set_gen.fold
+let length = Hash_set_gen.length
+let stats = Hash_set_gen.stats
+let elements = Hash_set_gen.elements
-external string_unsafe_set : string -> int -> char -> unit
- = "%string_unsafe_set"
-
-external string_create: int -> string = "caml_create_string"
-
-external unsafe_chr: int -> char = "%identity"
-(** {!Char.escaped} is locale sensitive in 4.02.3, fixed in the trunk,
- backport it here
- *)
-let escaped = function
- | '\'' -> "\\'"
- | '\\' -> "\\\\"
- | '\n' -> "\\n"
- | '\t' -> "\\t"
- | '\r' -> "\\r"
- | '\b' -> "\\b"
- | ' ' .. '~' as c ->
- let s = string_create 1 in
- string_unsafe_set s 0 c;
- s
- | c ->
- let n = Char.code c in
- let s = string_create 4 in
- string_unsafe_set s 0 '\\';
- string_unsafe_set s 1 (unsafe_chr (48 + n / 100));
- string_unsafe_set s 2 (unsafe_chr (48 + (n / 10) mod 10));
- string_unsafe_set s 3 (unsafe_chr (48 + n mod 10));
- s
+let remove (h : _ Hash_set_gen.t) key =
+ let i = key_index h key in
+ let h_data = h.data in
+ let old_h_size = h.size in
+ let new_bucket = Hash_set_gen.remove_bucket eq_key key h (Array.unsafe_get h_data i) in
+ if old_h_size <> h.size then
+ Array.unsafe_set h_data i new_bucket
-let valid_hex x =
- match x with
- | '0' .. '9'
- | 'a' .. 'f'
- | 'A' .. 'F' -> true
- | _ -> false
+
+let add (h : _ Hash_set_gen.t) key =
+ let i = key_index h key in
+ let h_data = h.data in
+ let old_bucket = (Array.unsafe_get h_data i) in
+ if not (Hash_set_gen.small_bucket_mem eq_key key old_bucket) then
+ begin
+ Array.unsafe_set h_data i (key :: old_bucket);
+ h.size <- h.size + 1 ;
+ if h.size > Array.length h_data lsl 1 then Hash_set_gen.resize key_index h
+ end
+
+let of_array arr =
+ let len = Array.length arr in
+ let tbl = create len in
+ for i = 0 to len - 1 do
+ add tbl (Array.unsafe_get arr i);
+ done ;
+ tbl
+
+
+let check_add (h : _ Hash_set_gen.t) key =
+ let i = key_index h key in
+ let h_data = h.data in
+ let old_bucket = (Array.unsafe_get h_data i) in
+ if not (Hash_set_gen.small_bucket_mem eq_key key old_bucket) then
+ begin
+ Array.unsafe_set h_data i (key :: old_bucket);
+ h.size <- h.size + 1 ;
+ if h.size > Array.length h_data lsl 1 then Hash_set_gen.resize key_index h;
+ true
+ end
+ else false
+let mem (h : _ Hash_set_gen.t) key =
+ Hash_set_gen.small_bucket_mem eq_key key (Array.unsafe_get h.data (key_index h key))
+
+
-let is_lower_case c =
- (c >= 'a' && c <= 'z')
- || (c >= '\224' && c <= '\246')
- || (c >= '\248' && c <= '\254')
end
-module Ast_utf8_string : sig
-#1 "ast_utf8_string.mli"
+module Lam_methname : sig
+#1 "lam_methname.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -31929,28 +32164,13 @@ module Ast_utf8_string : sig
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-type error
-
-
-type exn += Error of int (* offset *) * error
-
-val pp_error : Format.formatter -> error -> unit
-
-
-
-(* module Interp : sig *)
-(* val check_and_transform : int -> string -> int -> cxt -> unit *)
-(* val transform_test : string -> segments *)
-(* end *)
-val transform_test : string -> string
-
-val transform : Location.t -> string -> string
+val translate : ?loc:Location.t -> string -> string
end = struct
-#1 "ast_utf8_string.ml"
+#1 "lam_methname.ml"
(* 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
@@ -31968,189 +32188,142 @@ end = struct
* 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. *)
+(**
+ {[
+ _open -> open
+ _in -> in
+ _MAX_LENGTH -> MAX_LENGTH
+ _Capital -> Capital
+
+ _open__ -> _open
+ open__ -> open
+
+ _'x -> 'x
-type error =
- | Invalid_code_point
- | Unterminated_backslash
- | Invalid_escape_code of char
- | Invalid_hex_escape
- | Invalid_unicode_escape
-
-let pp_error fmt err =
- Format.pp_print_string fmt @@ match err with
- | Invalid_code_point -> "Invalid code point"
- | Unterminated_backslash -> "\\ ended unexpectedly"
- | Invalid_escape_code c -> "Invalid escape code: " ^ String.make 1 c
- | Invalid_hex_escape ->
- "Invalid \\x escape"
- | Invalid_unicode_escape -> "Invalid \\u escape"
+ _Capital__ -> _Capital
+ _MAX__ -> _MAX
+ __ -> __
+ __x -> __x
+ ___ -> _
+ ____ -> __
+ _ -> _ (* error *)
+
+ ]}
+ First we scan '__' from end to start,
+ If found, discard it.
+ Otherwise, check if it is [_ + keyword] or followed by capital letter,
+ If so, discard [_].
+ Limitations: user can not have [_Capital__, _Capital__other] to
+ make it all compile to [Capital].
+ Keyword is fine [open__, open__other].
+ So we loose polymorphism over capital letter.
+ It is okay, otherwise, if [_Captial__] is interpreted as [Capital], then
+ there is no way to express [_Capital]
+*)
-type exn += Error of int (* offset *) * error
+(* Copied from [ocaml/parsing/lexer.mll] *)
+let key_words = String_hash_set.of_array [|
+ "and";
+ "as";
+ "assert";
+ "begin";
+ "class";
+ "constraint";
+ "do";
+ "done";
+ "downto";
+ "else";
+ "end";
+ "exception";
+ "external";
+ "false";
+ "for";
+ "fun";
+ "function";
+ "functor";
+ "if";
+ "in";
+ "include";
+ "inherit";
+ "initializer";
+ "lazy";
+ "let";
+ "match";
+ "method";
+ "module";
+ "mutable";
+ "new";
+ "nonrec";
+ "object";
+ "of";
+ "open";
+ "or";
+(* "parser", PARSER; *)
+ "private";
+ "rec";
+ "sig";
+ "struct";
+ "then";
+ "to";
+ "true";
+ "try";
+ "type";
+ "val";
+ "virtual";
+ "when";
+ "while";
+ "with";
+ "mod";
+ "land";
+ "lor";
+ "lxor";
+ "lsl";
+ "lsr";
+ "asr";
+|]
+let double_underscore = "__"
+(*https://caml.inria.fr/pub/docs/manual-ocaml/lex.html
+{[
-
-let error ~loc error =
- raise (Error (loc, error))
-
-(** Note the [loc] really should be the utf8-offset, it has nothing to do with our
- escaping mechanism
-*)
-(* we can not just print new line in ES5
- seems we don't need
- escape "\b" "\f"
- we need escape "\n" "\r" since
- ocaml multiple-line allows [\n]
- visual input while es5 string
- does not*)
-
-let rec check_and_transform (loc : int ) buf s byte_offset s_len =
- if byte_offset = s_len then ()
- else
- let current_char = s.[byte_offset] in
- match Ext_utf8.classify current_char with
- | Single 92 (* '\\' *) ->
- escape_code (loc + 1) buf s (byte_offset+1) s_len
- | Single 34 ->
- Buffer.add_string buf "\\\"";
- check_and_transform (loc + 1) buf s (byte_offset + 1) s_len
- | Single 39 ->
- Buffer.add_string buf "\\'";
- check_and_transform (loc + 1) buf s (byte_offset + 1) s_len
- | Single 10 ->
- Buffer.add_string buf "\\n";
- check_and_transform (loc + 1) buf s (byte_offset + 1) s_len
- | Single 13 ->
- Buffer.add_string buf "\\r";
- check_and_transform (loc + 1) buf s (byte_offset + 1) s_len
- | Single _ ->
- Buffer.add_char buf current_char;
- check_and_transform (loc + 1) buf s (byte_offset + 1) s_len
-
- | Invalid
- | Cont _ -> error ~loc Invalid_code_point
- | Leading (n,_) ->
- let i' = Ext_utf8.next s ~remaining:n byte_offset in
- if i' < 0 then
- error ~loc Invalid_code_point
- else
- begin
- for k = byte_offset to i' do
- Buffer.add_char buf s.[k];
- done;
- check_and_transform (loc + 1 ) buf s (i' + 1) s_len
- end
-(* we share the same escape sequence with js *)
-and escape_code loc buf s offset s_len =
- if offset >= s_len then
- error ~loc Unterminated_backslash
- else
- Buffer.add_char buf '\\';
- let cur_char = s.[offset] in
- match cur_char with
- | '\\'
- | 'b'
- | 't'
- | 'n'
- | 'v'
- | 'f'
- | 'r'
- | '0'
- | '$'
- ->
- begin
- Buffer.add_char buf cur_char ;
- check_and_transform (loc + 1) buf s (offset + 1) s_len
- end
- | 'u' ->
- begin
- Buffer.add_char buf cur_char;
- unicode (loc + 1) buf s (offset + 1) s_len
- end
- | 'x' -> begin
- Buffer.add_char buf cur_char ;
- two_hex (loc + 1) buf s (offset + 1) s_len
- end
- | _ -> error ~loc (Invalid_escape_code cur_char)
-and two_hex loc buf s offset s_len =
- if offset + 1 >= s_len then
- error ~loc Invalid_hex_escape;
- (*Location.raise_errorf ~loc "\\x need at least two chars";*)
- let a, b = s.[offset], s.[offset + 1] in
- if Ext_char.valid_hex a && Ext_char.valid_hex b then
- begin
- Buffer.add_char buf a ;
- Buffer.add_char buf b ;
- check_and_transform (loc + 2) buf s (offset + 2) s_len
- end
- else
- error ~loc Invalid_hex_escape
-(*Location.raise_errorf ~loc "%c%c is not a valid hex code" a b*)
-
-and unicode loc buf s offset s_len =
- if offset + 3 >= s_len then
- error ~loc Invalid_unicode_escape
- (*Location.raise_errorf ~loc "\\u need at least four chars"*)
- ;
- let a0,a1,a2,a3 = s.[offset], s.[offset+1], s.[offset+2], s.[offset+3] in
- if
- Ext_char.valid_hex a0 &&
- Ext_char.valid_hex a1 &&
- Ext_char.valid_hex a2 &&
- Ext_char.valid_hex a3 then
- begin
- Buffer.add_char buf a0;
- Buffer.add_char buf a1;
- Buffer.add_char buf a2;
- Buffer.add_char buf a3;
- check_and_transform (loc + 4) buf s (offset + 4) s_len
- end
- else
- error ~loc Invalid_unicode_escape
-(*Location.raise_errorf ~loc "%c%c%c%c is not a valid unicode point"
- a0 a1 a2 a3 *)
-(* http://www.2ality.com/2015/01/es6-strings.html
- console.log('\uD83D\uDE80'); (* ES6*)
- console.log('\u{1F680}');
-*)
-
-
-
-
-
-
-
-
-
-let transform_test s =
- let s_len = String.length s in
- let buf = Buffer.create (s_len * 2) in
- check_and_transform 0 buf s 0 s_len;
- Buffer.contents buf
-
-let transform loc s =
- let s_len = String.length s in
- let buf = Buffer.create (s_len * 2) in
- try
- check_and_transform 0 buf s 0 s_len;
- Buffer.contents buf
- with
- Error (offset, error)
- -> Location.raise_errorf ~loc "Offset: %d, %a" offset pp_error error
-
+ label-name ::= lowercase-ident
+]}
+*)
+let valid_start_char x =
+ match x with
+ | '_' | 'a' .. 'z' -> true
+ | _ -> false
+let translate ?loc name =
+ assert (not @@ Ext_string.is_empty name);
+ let i = Ext_string.rfind ~sub:double_underscore name in
+ if i < 0 then
+ let name_len = String.length name in
+ if name.[0] = '_' then begin
+ let try_key_word = (String.sub name 1 (name_len - 1)) in
+ if name_len > 1 &&
+ (not (valid_start_char try_key_word.[0])
+ || String_hash_set.mem key_words try_key_word) then
+ try_key_word
+ else
+ name
+ end
+ else name
+ else if i = 0 then name
+ else String.sub name 0 i
end
-module Bs_loc : sig
-#1 "bs_loc.mli"
+module External_process : sig
+#1 "external_process.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -32175,65 +32348,40 @@ module Bs_loc : sig
* 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 = Location.t = {
- loc_start : Lexing.position;
- loc_end : Lexing.position ;
- loc_ghost : bool
-}
-val is_ghost : t -> bool
-val merge : t -> t -> t
-val none : t
-end = struct
-#1 "bs_loc.ml"
-(* 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. *)
+
+(**
+ [handle_attributes_as_string
+ loc pval_name.txt pval_type pval_attributes pval_prim]
+ [pval_name.txt] is the name of identifier
+ [pval_prim] is the name of string literal
+
+ return value is of [pval_type, pval_prims, new_attrs]
+*)
+val handle_attributes_as_string :
+ Bs_loc.t ->
+ string ->
+ Ast_core_type.t ->
+ Ast_attributes.t ->
+ string ->
+ Ast_core_type.t * string list * Ast_attributes.t
-type t = Location.t = {
- loc_start : Lexing.position;
- loc_end : Lexing.position ;
- loc_ghost : bool
-}
-let is_ghost x = x.loc_ghost
-let merge (l: t) (r : t) =
- if is_ghost l then r
- else if is_ghost r then l
- else match l,r with
- | {loc_start ; }, {loc_end; _} (* TODO: improve*)
- ->
- {loc_start ;loc_end; loc_ghost = false}
+(** [pval_prim_of_labels labels]
+ return [pval_prims] for FFI, it is specialized for
+ external object which is used in
+ {[ [%obj { x = 2; y = 1} ] ]}
+*)
+val pval_prim_of_labels : string Asttypes.loc list -> string list
-let none = Location.none
-end
-module Ast_utf8_string_interp : sig
-#1 "ast_utf8_string_interp.mli"
+
+end = struct
+#1 "external_process.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -32259,2028 +32407,1841 @@ module Ast_utf8_string_interp : sig
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-type kind =
- | String
- | Var
-type error = private
- | Invalid_code_point
- | Unterminated_backslash
- | Invalid_escape_code of char
- | Invalid_hex_escape
- | Invalid_unicode_escape
- | Unterminated_variable
- | Unmatched_paren
- | Invalid_syntax_of_var of string
-
-(** Note the position is about code point *)
-type pos = { lnum : int ; offset : int ; byte_bol : int }
-
-type segment = {
- start : pos;
- finish : pos ;
- kind : kind;
- content : string ;
-}
+[@@@ocaml.warning "+9"]
-type segments = segment list
-type cxt = {
- mutable segment_start : pos ;
- buf : Buffer.t ;
- s_len : int ;
- mutable segments : segments;
- mutable pos_bol : int; (* record the abs position of current beginning line *)
- mutable byte_bol : int ;
- mutable pos_lnum : int ; (* record the line number *)
-}
-type exn += Error of pos * pos * error
-
-val empty_segment : segment -> bool
-
-val transform_test : string -> segment list
-val transform_interp : Location.t -> string -> Parsetree.expression
-
-end = struct
-#1 "ast_utf8_string_interp.ml"
-(* 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 variant_can_bs_unwrap_fields row_fields =
+ let validity =
+ List.fold_left
+ begin fun st row ->
+ match st, row with
+ | (* we've seen no fields or only valid fields so far *)
+ (`No_fields | `Valid_fields),
+ (* and this field has one constructor arg that we can unwrap to *)
+ Parsetree.Rtag (label, attrs, false, ([ _ ]))
+ ->
+ `Valid_fields
+ | (* otherwise, this field or a previous field was invalid *)
+ _ ->
+ `Invalid_field
+ end
+ `No_fields
+ row_fields
+ in
+ match validity with
+ | `Valid_fields -> true
+ | `No_fields
+ | `Invalid_field -> false
-type error =
- | Invalid_code_point
- | Unterminated_backslash
- | Invalid_escape_code of char
- | Invalid_hex_escape
- | Invalid_unicode_escape
- | Unterminated_variable
- | Unmatched_paren
- | Invalid_syntax_of_var of string
-type kind =
- | String
- | Var
+(** Given the type of argument, process its [bs.] attribute and new type,
+ The new type is currently used to reconstruct the external type
+ and result type in [@@bs.obj]
+ They are not the same though, for example
+ {[
+ external f : hi:([ `hi | `lo ] [@bs.string]) -> unit -> _ = "" [@@bs.obj]
+ ]}
+ The result type would be [ hi:string ]
+*)
+let get_arg_type ~nolabel optional
+ (ptyp : Ast_core_type.t) :
+ External_arg_spec.attr * Ast_core_type.t =
+ let ptyp = if optional then Ast_core_type.extract_option_type_exn ptyp else ptyp in
+ if Ast_core_type.is_any ptyp then (* (_[@bs.as ])*)
+ if optional then
+ Bs_syntaxerr.err ptyp.ptyp_loc Invalid_underscore_type_in_external
+ else begin
+ let ptyp_attrs =
+ ptyp.Parsetree.ptyp_attributes
+ in
+ let result =
+ Ast_attributes.iter_process_bs_string_or_int_as ptyp_attrs
+ in
+ (* when ppx start dropping attributes
+ we should warn, there is a trade off whether
+ we should warn dropped non bs attribute or not
+ *)
+ Bs_ast_invariant.warn_unused_attributes ptyp_attrs;
+ match result with
+ | None ->
+ Bs_syntaxerr.err ptyp.ptyp_loc Invalid_underscore_type_in_external
-(** Note the position is about code point *)
-type pos = {
- lnum : int ;
- offset : int ;
- byte_bol : int (* Note it actually needs to be in sync with OCaml's lexing semantics *)
-}
+ | Some (`Int i) ->
+ Arg_cst(External_arg_spec.cst_int i), Ast_literal.type_int ~loc:ptyp.ptyp_loc ()
+ | Some (`Str i)->
+ Arg_cst (External_arg_spec.cst_string i), Ast_literal.type_string ~loc:ptyp.ptyp_loc ()
+ | Some (`Json_str s) ->
+ Arg_cst (External_arg_spec.cst_json ptyp.ptyp_loc s),
+ Ast_literal.type_string ~loc:ptyp.ptyp_loc ()
+ end
+ else (* ([`a|`b] [@bs.string]) *)
+ let ptyp_desc = ptyp.ptyp_desc in
+ match Ast_attributes.process_bs_string_int_unwrap_uncurry ptyp.ptyp_attributes with
+ | (`String, ptyp_attributes)
+ ->
+ begin match ptyp_desc with
+ | Ptyp_variant ( row_fields, Closed, None)
+ ->
+ let attr =
+ Ast_polyvar.map_row_fields_into_strings ptyp.ptyp_loc row_fields in
+ attr,
+ {ptyp with
+ ptyp_attributes
+ }
+ | _ ->
+ Bs_syntaxerr.err ptyp.ptyp_loc Invalid_bs_string_type
+ end
+ | (`Ignore, ptyp_attributes) ->
+ (Ignore, {ptyp with ptyp_attributes})
+ | (`Int , ptyp_attributes) ->
+ begin match ptyp_desc with
+ | Ptyp_variant ( row_fields, Closed, None) ->
+ let int_lists =
+ Ast_polyvar.map_row_fields_into_ints ptyp.ptyp_loc row_fields in
+ Int int_lists ,
+ {ptyp with
+ ptyp_attributes
+ }
+ | _ -> Bs_syntaxerr.err ptyp.ptyp_loc Invalid_bs_int_type
+ end
+ | (`Unwrap, ptyp_attributes) ->
-type segment = {
- start : pos;
- finish : pos ;
- kind : kind;
- content : string ;
-}
+ begin match ptyp_desc with
+ | (Ptyp_variant (row_fields, Closed, _) as ptyp_desc)
+ when variant_can_bs_unwrap_fields row_fields ->
+ Unwrap, {ptyp with ptyp_desc; ptyp_attributes}
+ | _ ->
+ Bs_syntaxerr.err ptyp.ptyp_loc Invalid_bs_unwrap_type
+ end
+ | (`Uncurry opt_arity, ptyp_attributes) ->
+ let real_arity = Ast_core_type.get_uncurry_arity ptyp in
+ (begin match opt_arity, real_arity with
+ | Some arity, `Not_function ->
+ Fn_uncurry_arity arity
+ | None, `Not_function ->
+ Bs_syntaxerr.err ptyp.ptyp_loc Canot_infer_arity_by_syntax
+ | None, `Arity arity ->
+ Fn_uncurry_arity arity
+ | Some arity, `Arity n ->
+ if n <> arity then
+ Bs_syntaxerr.err ptyp.ptyp_loc (Inconsistent_arity (arity,n))
+ else Fn_uncurry_arity arity
-type segments = segment list
+ end, {ptyp with ptyp_attributes})
+ | (`Nothing, ptyp_attributes) ->
+ begin match ptyp_desc with
+ | Ptyp_constr ({txt = Lident "bool"; _}, [])
+ ->
+ Bs_warnings.prerr_bs_ffi_warning ptyp.ptyp_loc Unsafe_ffi_bool_type;
+ Nothing
+ | Ptyp_constr ({txt = Lident "unit"; _}, [])
+ -> if nolabel then Extern_unit else Nothing
+ | Ptyp_constr ({txt = Lident "array"; _}, [_])
+ -> Array
+ | Ptyp_variant _ ->
+ Bs_warnings.prerr_bs_ffi_warning ptyp.ptyp_loc Unsafe_poly_variant_type;
+ Nothing
+ | _ ->
+ Nothing
+ end, ptyp
-type cxt = {
- mutable segment_start : pos ;
- buf : Buffer.t ;
- s_len : int ;
- mutable segments : segments;
- mutable pos_bol : int; (* record the abs position of current beginning line *)
- mutable byte_bol : int ;
- mutable pos_lnum : int ; (* record the line number *)
-}
+(**
+ [@@bs.module "react"]
+ [@@bs.module "react"]
+ ---
+ [@@bs.module "@" "react"]
+ [@@bs.module "@" "react"]
-type exn += Error of pos * pos * error
+ They should have the same module name
-let pp_error fmt err =
- Format.pp_print_string fmt @@ match err with
- | Invalid_code_point -> "Invalid code point"
- | Unterminated_backslash -> "\\ ended unexpectedly"
- | Invalid_escape_code c -> "Invalid escape code: " ^ String.make 1 c
- | Invalid_hex_escape ->
- "Invalid \\x escape"
- | Invalid_unicode_escape -> "Invalid \\u escape"
- | Unterminated_variable -> "$ unterminated"
- | Unmatched_paren -> "Unmatched paren"
- | Invalid_syntax_of_var s -> "`" ^s ^ "' is not a valid syntax of interpolated identifer"
-let valid_lead_identifier_char x =
- match x with
- | 'a'..'z' | '_' -> true
- | _ -> false
+ TODO: we should emit an warning if we bind
+ two external files to the same module name
+*)
+type bundle_source =
+ [`Nm_payload of string (* from payload [@@bs.val "xx" ]*)
+ |`Nm_external of string (* from "" in external *)
+ | `Nm_val of string (* from function name *)
+ ]
-let valid_identifier_char x =
+let string_of_bundle_source (x : bundle_source) =
match x with
- | 'a'..'z'
- | 'A'..'Z'
- | '0'..'9'
- | '_' | '\''-> true
- | _ -> false
-(** Invariant: [valid_lead_identifier] has to be [valid_identifier] *)
+ | `Nm_payload x
+ | `Nm_external x
+ | `Nm_val x -> x
+type name_source =
+ [ bundle_source
+ | `Nm_na
-let valid_identifier s =
- let s_len = String.length s in
- if s_len = 0 then false
- else
- valid_lead_identifier_char s.[0] &&
- Ext_string.for_all_from s 1 valid_identifier_char
+ ]
-
-let is_space x =
- match x with
- | ' ' | '\n' | '\t' -> true
- | _ -> false
-(**
- FIXME: multiple line offset
- if there is no line offset. Note {|{j||} border will never trigger a new line
-*)
-let update_position border
- ({lnum ; offset;byte_bol } : pos)
- (pos : Lexing.position)=
- if lnum = 0 then
- {pos with pos_cnum = pos.pos_cnum + border + offset }
- (** When no newline, the column number is [border + offset] *)
- else
- {
- pos with
- pos_lnum = pos.pos_lnum + lnum ;
- pos_bol = pos.pos_cnum + border + byte_bol;
- pos_cnum = pos.pos_cnum + border + byte_bol + offset;
- (** when newline, the column number is [offset] *)
- }
-let update border
- (start : pos)
- (finish : pos) (loc : Location.t) : Location.t =
- let start_pos = loc.loc_start in
- { loc with
- loc_start =
- update_position border start start_pos;
- loc_end =
- update_position border finish start_pos
+type st =
+ { val_name : name_source;
+ external_module_name : External_ffi_types.external_module_name option;
+ module_as_val : External_ffi_types.external_module_name option;
+ val_send : name_source ;
+ val_send_pipe : Ast_core_type.t option;
+ splice : bool ; (* mutable *)
+ scopes : string list ;
+ set_index : bool; (* mutable *)
+ get_index : bool;
+ new_name : name_source ;
+ call_name : name_source ;
+ set_name : name_source ;
+ get_name : name_source ;
+
+ mk_obj : bool ;
+ return_wrapper : External_ffi_types.return_wrapper ;
+
}
+let init_st =
+ {
+ val_name = `Nm_na;
+ external_module_name = None ;
+ module_as_val = None;
+ val_send = `Nm_na;
+ val_send_pipe = None;
+ splice = false;
+ scopes = [];
+ set_index = false;
+ get_index = false;
+ new_name = `Nm_na;
+ call_name = `Nm_na;
+ set_name = `Nm_na ;
+ get_name = `Nm_na ;
+ mk_obj = false ;
+ return_wrapper = Return_unset;
-(** Note [Var] kind can not be mpty *)
-let empty_segment {content } =
- Ext_string.is_empty content
+ }
-let update_newline ~byte_bol loc cxt =
- cxt.pos_lnum <- cxt.pos_lnum + 1 ;
- cxt.pos_bol <- loc;
- cxt.byte_bol <- byte_bol
-let pos_error cxt ~loc error =
- raise (Error
- (cxt.segment_start,
- { lnum = cxt.pos_lnum ; offset = loc - cxt.pos_bol ; byte_bol = cxt.byte_bol}, error))
-let add_var_segment cxt loc =
- let content = Buffer.contents cxt.buf in
- Buffer.clear cxt.buf ;
- let next_loc = {
- lnum = cxt.pos_lnum ; offset = loc - cxt.pos_bol ;
- byte_bol = cxt.byte_bol } in
- if valid_identifier content then
- begin
- cxt.segments <-
- { start = cxt.segment_start;
- finish = next_loc ;
- kind = Var;
- content} :: cxt.segments ;
- cxt.segment_start <- next_loc
- end
- else pos_error cxt ~loc (Invalid_syntax_of_var content)
+let process_external_attributes
+ no_arguments
+ (prim_name_or_pval_prim: [< bundle_source ] as 'a)
+ pval_prim
+ (prim_attributes : Ast_attributes.t) : _ * Ast_attributes.t =
-let add_str_segment cxt loc =
- let content = Buffer.contents cxt.buf in
- Buffer.clear cxt.buf ;
- let next_loc = {
- lnum = cxt.pos_lnum ; offset = loc - cxt.pos_bol ;
- byte_bol = cxt.byte_bol } in
- cxt.segments <-
- { start = cxt.segment_start;
- finish = next_loc ;
- kind = String;
- content} :: cxt.segments ;
- cxt.segment_start <- next_loc
+ (* shared by `[@@bs.val]`, `[@@bs.send]`,
+ `[@@bs.set]`, `[@@bs.get]` , `[@@bs.new]`
+ `[@@bs.send.pipe]` does not use it
+ *)
+ let name_from_payload_or_prim ~loc (payload : Parsetree.payload) : name_source =
+ match payload with
+ | PStr [] ->
+ (prim_name_or_pval_prim :> name_source)
+ (* It is okay to have [@@bs.val] without payload *)
+ | _ ->
+ begin match Ast_payload.is_single_string payload with
+ | Some (val_name, _) -> `Nm_payload val_name
+ | None ->
+ Location.raise_errorf ~loc "Invalid payload"
+ end
+ in
+ List.fold_left
+ (fun (st, attrs)
+ (({txt ; loc}, payload) as attr : Ast_attributes.attr)
+ ->
+ if Ext_string.starts_with txt "bs." then
+ begin match txt with
+ | "bs.val" ->
+ if no_arguments then
+ {st with val_name = name_from_payload_or_prim ~loc payload}
+ else
+ {st with call_name = name_from_payload_or_prim ~loc payload}
-
+ | "bs.module" ->
+ begin match Ast_payload.assert_strings loc payload with
+ | [bundle] ->
+ {st with external_module_name =
+ Some {bundle; module_bind_name = Phint_nothing}}
+ | [bundle;bind_name] ->
+ {st with external_module_name =
+ Some {bundle; module_bind_name = Phint_name bind_name}}
+ | [] ->
+ { st with
+ module_as_val =
+ Some
+ { bundle =
+ string_of_bundle_source
+ (prim_name_or_pval_prim :> bundle_source) ;
+ module_bind_name = Phint_nothing}
+ }
+ | _ ->
+ Bs_syntaxerr.err loc Illegal_attribute
+ end
+ | "bs.scope" ->
+ begin match Ast_payload.assert_strings loc payload with
+ | [] ->
+ Bs_syntaxerr.err loc Illegal_attribute
+ (* We need err on empty scope, so we can tell the difference
+ between unset/set
+ *)
+ | scopes -> { st with scopes = scopes }
+ end
+ | "bs.splice" -> {st with splice = true}
+ | "bs.send" ->
+ { st with val_send = name_from_payload_or_prim ~loc payload}
+ | "bs.send.pipe"
+ ->
+ { st with val_send_pipe = Some (Ast_payload.as_core_type loc payload)}
+ | "bs.set" ->
+ {st with set_name = name_from_payload_or_prim ~loc payload}
+ | "bs.get" -> {st with get_name = name_from_payload_or_prim ~loc payload}
+ | "bs.new" -> {st with new_name = name_from_payload_or_prim ~loc payload}
+ | "bs.set_index" -> {st with set_index = true}
+ | "bs.get_index"-> {st with get_index = true}
+ | "bs.obj" -> {st with mk_obj = true}
+ | "bs.return" ->
+ let aux loc txt : External_ffi_types.return_wrapper =
+ begin match txt with
+ | "undefined_to_opt" -> Return_undefined_to_opt
+ | "null_to_opt" -> Return_null_to_opt
+ | "nullable"
+ | "null_undefined_to_opt" -> Return_null_undefined_to_opt
+ | "identity" -> Return_identity
+ | _ ->
+ Bs_syntaxerr.err loc Not_supported_directive_in_bs_return
+ end in
+ let actions =
+ Ast_payload.ident_or_record_as_config loc payload
+ in
+ begin match actions with
+ | [ ({txt; _ },None) ] ->
+ { st with return_wrapper = aux loc txt}
+ | _ ->
+ Bs_syntaxerr.err loc Not_supported_directive_in_bs_return
+ end
+ | _ -> (Location.prerr_warning loc (Bs_unused_attribute txt); st)
+ end, attrs
+ else (st , attr :: attrs)
+ )
+ (init_st, []) prim_attributes
-let rec check_and_transform (loc : int ) s byte_offset ({s_len; buf} as cxt : cxt) =
- if byte_offset = s_len then
- add_str_segment cxt loc
- else
- let current_char = s.[byte_offset] in
- match Ext_utf8.classify current_char with
- | Single 92 (* '\\' *) ->
- escape_code (loc + 1) s (byte_offset+1) cxt
- | Single 34 ->
- Buffer.add_string buf "\\\"";
- check_and_transform (loc + 1) s (byte_offset + 1) cxt
- | Single 39 ->
- Buffer.add_string buf "\\'";
- check_and_transform (loc + 1) s (byte_offset + 1) cxt
- | Single 10 ->
- Buffer.add_string buf "\\n";
- let loc = loc + 1 in
- let byte_offset = byte_offset + 1 in
- update_newline ~byte_bol:byte_offset loc cxt ; (* Note variable could not have new-line *)
- check_and_transform loc s byte_offset cxt
- | Single 13 ->
- Buffer.add_string buf "\\r";
- check_and_transform (loc + 1) s (byte_offset + 1) cxt
- | Single 36 -> (* $ *)
- add_str_segment cxt loc ;
- let offset = byte_offset + 1 in
- if offset >= s_len then
- pos_error ~loc cxt Unterminated_variable
- else
- let cur_char = s.[offset] in
- if cur_char = '(' then
- expect_var_paren (loc + 2) s (offset + 1) cxt
- else
- expect_simple_var (loc + 1) s offset cxt
- | Single _ ->
- Buffer.add_char buf current_char;
- check_and_transform (loc + 1) s (byte_offset + 1) cxt
+let rec has_bs_uncurry (attrs : Ast_attributes.t) =
+ match attrs with
+ | ({txt = "bs.uncurry"; _ }, _) :: attrs ->
+ true
+ | _ :: attrs -> has_bs_uncurry attrs
+ | [] -> false
- | Invalid
- | Cont _ -> pos_error ~loc cxt Invalid_code_point
- | Leading (n,_) ->
- let i' = Ext_utf8.next s ~remaining:n byte_offset in
- if i' < 0 then
- pos_error cxt ~loc Invalid_code_point
- else
- begin
- for k = byte_offset to i' do
- Buffer.add_char buf s.[k];
- done;
- check_and_transform (loc + 1 ) s (i' + 1) cxt
- end
-(**Lets keep identifier simple, so that we could generating a function easier in the future
- for example
- let f = [%fn{| $x + $y = $x_add_y |}]
-*)
-and expect_simple_var loc s offset ({buf; s_len} as cxt) =
- let v = ref offset in
- (* prerr_endline @@ Ext_pervasives.dump (s, has_paren, (is_space s.[!v]), !v); *)
- if not (offset < s_len && valid_lead_identifier_char s.[offset]) then
- pos_error cxt ~loc (Invalid_syntax_of_var Ext_string.empty)
- else
- begin
- while !v < s_len && valid_identifier_char s.[!v] do (* TODO*)
- let cur_char = s.[!v] in
- Buffer.add_char buf cur_char;
- incr v ;
- done;
- let added_length = !v - offset in
- let loc = added_length + loc in
- add_var_segment cxt loc ;
- check_and_transform loc s (added_length + offset) cxt
- end
-and expect_var_paren loc s offset ({buf; s_len} as cxt) =
- let v = ref offset in
- (* prerr_endline @@ Ext_pervasives.dump (s, has_paren, (is_space s.[!v]), !v); *)
- while !v < s_len && s.[!v] <> ')' do
- let cur_char = s.[!v] in
- Buffer.add_char buf cur_char;
- incr v ;
- done;
- let added_length = !v - offset in
- let loc = added_length + 1 + loc in
- if !v < s_len && s.[!v] = ')' then
- begin
- add_var_segment cxt loc ;
- check_and_transform loc s (added_length + 1 + offset) cxt
- end
- else
- pos_error cxt ~loc Unmatched_paren
+let check_return_wrapper
+ loc (wrapper : External_ffi_types.return_wrapper)
+ result_type =
+ match wrapper with
+ | Return_identity -> wrapper
+ | Return_unset ->
+ if Ast_core_type.is_unit result_type then
+ Return_replaced_with_unit
+ else if Ast_core_type.is_user_bool result_type then
+ Return_to_ocaml_bool
+ else
+ wrapper
+ | Return_undefined_to_opt
+ | Return_null_to_opt
+ | Return_null_undefined_to_opt
+ ->
+ if Ast_core_type.is_user_option result_type then
+ wrapper
+ else
+ Bs_syntaxerr.err loc Expect_opt_in_bs_return_to_opt
+ | Return_replaced_with_unit
+ | Return_to_ocaml_bool ->
+ assert false (* Not going to happen from user input*)
-(* we share the same escape sequence with js *)
-and escape_code loc s offset ({ buf; s_len} as cxt) =
- if offset >= s_len then
- pos_error cxt ~loc Unterminated_backslash
- else
- Buffer.add_char buf '\\';
- let cur_char = s.[offset] in
- match cur_char with
- | '\\'
- | 'b'
- | 't'
- | 'n'
- | 'v'
- | 'f'
- | 'r'
- | '0'
- | '$'
- ->
- begin
- Buffer.add_char buf cur_char ;
- check_and_transform (loc + 1) s (offset + 1) cxt
- end
- | 'u' ->
- begin
- Buffer.add_char buf cur_char;
- unicode (loc + 1) s (offset + 1) cxt
- end
- | 'x' -> begin
- Buffer.add_char buf cur_char ;
- two_hex (loc + 1) s (offset + 1) cxt
- end
- | _ -> pos_error cxt ~loc (Invalid_escape_code cur_char)
-and two_hex loc s offset ({buf ; s_len} as cxt) =
- if offset + 1 >= s_len then
- pos_error cxt ~loc Invalid_hex_escape;
- let a, b = s.[offset], s.[offset + 1] in
- if Ext_char.valid_hex a && Ext_char.valid_hex b then
+(** Note that the passed [type_annotation] is already processed by visitor pattern before
+*)
+let handle_attributes
+ (loc : Bs_loc.t)
+ (pval_prim : string )
+ (type_annotation : Parsetree.core_type)
+ (prim_attributes : Ast_attributes.t) (prim_name : string)
+ : Ast_core_type.t * string * External_ffi_types.t * Ast_attributes.t =
+ (** sanity check here
+ {[ int -> int -> (int -> int -> int [@bs.uncurry])]}
+ It does not make sense
+ *)
+ if has_bs_uncurry type_annotation.Parsetree.ptyp_attributes then
begin
- Buffer.add_char buf a ;
- Buffer.add_char buf b ;
- check_and_transform (loc + 2) s (offset + 2) cxt
- end
- else
- pos_error cxt ~loc Invalid_hex_escape
-
+ Location.raise_errorf
+ ~loc "[@@bs.uncurry] can not be applied to the whole definition"
+ end;
-and unicode loc s offset ({buf ; s_len} as cxt) =
- if offset + 3 >= s_len then
- pos_error cxt ~loc Invalid_unicode_escape
- ;
- let a0,a1,a2,a3 = s.[offset], s.[offset+1], s.[offset+2], s.[offset+3] in
- if
- Ext_char.valid_hex a0 &&
- Ext_char.valid_hex a1 &&
- Ext_char.valid_hex a2 &&
- Ext_char.valid_hex a3 then
+ let prim_name_or_pval_prim =
+ if String.length prim_name = 0 then `Nm_val pval_prim
+ else `Nm_external prim_name (* need check name *)
+ in
+ let result_type, arg_types_ty =
+ Ast_core_type.list_of_arrow type_annotation in
+ if has_bs_uncurry result_type.ptyp_attributes then
begin
- Buffer.add_char buf a0;
- Buffer.add_char buf a1;
- Buffer.add_char buf a2;
- Buffer.add_char buf a3;
- check_and_transform (loc + 4) s (offset + 4) cxt
- end
- else
- pos_error cxt ~loc Invalid_unicode_escape
-let transform_test s =
- let s_len = String.length s in
- let buf = Buffer.create (s_len * 2) in
- let cxt =
- { segment_start = {lnum = 0; offset = 0; byte_bol = 0};
- buf ;
- s_len;
- segments = [];
- pos_lnum = 0;
- byte_bol = 0;
- pos_bol = 0;
-
- } in
- check_and_transform 0 s 0 cxt;
- List.rev cxt.segments
-
+ Location.raise_errorf
+ ~loc:result_type.ptyp_loc
+ "[@@bs.uncurry] can not be applied to tailed position"
+ end ;
+ let (st, left_attrs) =
+ process_external_attributes
+ (arg_types_ty = [])
+ prim_name_or_pval_prim pval_prim prim_attributes in
-(** TODO: test empty var $() $ failure,
- Allow identifers x.A.y *)
-open Ast_helper
+ if st.mk_obj then
+ begin match st with
+ | {
+ val_name = `Nm_na;
+ external_module_name = None ;
+ module_as_val = None;
+ val_send = `Nm_na;
+ val_send_pipe = None;
+ splice = false;
+ new_name = `Nm_na;
+ call_name = `Nm_na;
+ set_name = `Nm_na ;
+ get_name = `Nm_na ;
+ get_index = false ;
+ return_wrapper = Return_unset ;
+ set_index = false ;
+ mk_obj = _;
+ scopes = [];
+ (* wrapper does not work with [bs.obj]
+ TODO: better error message *)
+ } ->
+ if String.length prim_name <> 0 then
+ Location.raise_errorf ~loc "[@@bs.obj] expect external names to be empty string";
+ let arg_kinds, new_arg_types_ty, result_types =
+ Ext_list.fold_right
+ (fun (label,ty,attr,loc) ( arg_labels, arg_types, result_types) ->
+ let arg_label = Ast_core_type.label_name label in
+ let new_arg_label, new_arg_types, output_tys =
+ match arg_label with
+ | Empty ->
+ let arg_type, new_ty = get_arg_type ~nolabel:true false ty in
+ begin match arg_type with
+ | Extern_unit ->
+ External_arg_spec.empty_kind arg_type, (label,new_ty,attr,loc)::arg_types, result_types
+ | _ ->
+ Location.raise_errorf ~loc "expect label, optional, or unit here"
+ end
+ | Label name ->
+ let arg_type, new_ty = get_arg_type ~nolabel:false false ty in
+ begin match arg_type with
+ | Ignore ->
+ External_arg_spec.empty_kind arg_type,
+ (label,new_ty,attr,loc)::arg_types, result_types
+ | Arg_cst i ->
+ let s = (Lam_methname.translate ~loc name) in
+ {arg_label = External_arg_spec.label s (Some i);
+ arg_type },
+ arg_types, (* ignored in [arg_types], reserved in [result_types] *)
+ ((name , [], new_ty) :: result_types)
+ | Nothing | Array ->
+ let s = (Lam_methname.translate ~loc name) in
+ {arg_label = External_arg_spec.label s None ; arg_type },
+ (label,new_ty,attr,loc)::arg_types,
+ ((name , [], new_ty) :: result_types)
+ | Int _ ->
+ let s = Lam_methname.translate ~loc name in
+ {arg_label = External_arg_spec.label s None; arg_type},
+ (label,new_ty,attr,loc)::arg_types,
+ ((name, [], Ast_literal.type_int ~loc ()) :: result_types)
+ | NullString _ ->
+ let s = Lam_methname.translate ~loc name in
+ {arg_label = External_arg_spec.label s None; arg_type},
+ (label,new_ty,attr,loc)::arg_types,
+ ((name, [], Ast_literal.type_string ~loc ()) :: result_types)
+ | Fn_uncurry_arity _ ->
+ Location.raise_errorf ~loc
+ "The combination of [@@bs.obj], [@@bs.uncurry] is not supported yet"
+ | Extern_unit -> assert false
+ | NonNullString _
+ ->
+ Location.raise_errorf ~loc
+ "bs.obj label %s does not support such arg type" name
+ | Unwrap ->
+ Location.raise_errorf ~loc
+ "bs.obj label %s does not support [@bs.unwrap] arguments" name
+ end
+ | Optional name ->
+ let arg_type, new_ty_extract = get_arg_type ~nolabel:false true ty in
+ let new_ty = Ast_core_type.lift_option_type new_ty_extract in
+ begin match arg_type with
+ | Ignore ->
+ External_arg_spec.empty_kind arg_type,
+ (label,new_ty,attr,loc)::arg_types, result_types
-(** Longident.parse "Pervasives.^" *)
-let concat_ident : Longident.t =
- Ldot (Lident "Pervasives", "^")
- (* JS string concatMany *)
- (* Ldot (Ldot (Lident "Js", "String"), "concat") *)
+ | Nothing | Array ->
+ let s = (Lam_methname.translate ~loc name) in
+ {arg_label = External_arg_spec.optional s; arg_type},
+ (label,new_ty,attr,loc)::arg_types,
+ ( (name, [], Ast_comb.to_undefined_type loc new_ty_extract) :: result_types)
+ | Int _ ->
+ let s = Lam_methname.translate ~loc name in
+ {arg_label = External_arg_spec.optional s ; arg_type },
+ (label,new_ty,attr,loc)::arg_types,
+ ((name, [], Ast_comb.to_undefined_type loc @@ Ast_literal.type_int ~loc ()) :: result_types)
+ | NullString _ ->
+ let s = Lam_methname.translate ~loc name in
+ {arg_label = External_arg_spec.optional s ; arg_type },
+ (label,new_ty,attr,loc)::arg_types,
+ ((name, [], Ast_comb.to_undefined_type loc @@ Ast_literal.type_string ~loc ()) :: result_types)
+ | Arg_cst _
+ ->
+ Location.raise_errorf ~loc "bs.as is not supported with optional yet"
+ | Fn_uncurry_arity _ ->
+ Location.raise_errorf ~loc
+ "The combination of [@@bs.obj], [@@bs.uncurry] is not supported yet"
+ | Extern_unit -> assert false
+ | NonNullString _
+ ->
+ Location.raise_errorf ~loc
+ "bs.obj label %s does not support such arg type" name
+ | Unwrap ->
+ Location.raise_errorf ~loc
+ "bs.obj label %s does not support [@bs.unwrap] arguments" name
+ end
+ in
+ (
+ new_arg_label::arg_labels,
+ new_arg_types,
+ output_tys)) arg_types_ty
+ ( [], [], []) in
-(* Longident.parse "Js.String.make" *)
-let to_string_ident : Longident.t =
- Ldot (Ldot (Lident "Js", "String"), "make")
+ let result =
+ if Ast_core_type.is_any result_type then
+ Ast_core_type.make_obj ~loc result_types
+ else
+ snd @@ get_arg_type ~nolabel:true false result_type (* result type can not be labeled *)
+ in
+ begin
+ (
+ Ext_list.fold_right (fun (label,ty,attrs,loc) acc ->
+ Ast_helper.Typ.arrow ~loc ~attrs label ty acc
+ ) new_arg_types_ty result
+ ) ,
+ prim_name,
+ Ffi_obj_create arg_kinds,
+ left_attrs
+ end
+ | _ -> Location.raise_errorf ~loc "Attribute found that conflicts with [@@bs.obj]"
-let escaped = Some Literals.escaped_j_delimiter
+ end
-let concat_exp
- (a : Parsetree.expression)
- (b : Parsetree.expression) : Parsetree.expression =
- let loc = Bs_loc.merge a.pexp_loc b.pexp_loc in
- Exp.apply ~loc
- (Exp.ident { txt =concat_ident; loc})
- ["",a ;
- "",b]
+ else
+ let splice = st.splice in
+ let arg_type_specs, new_arg_types_ty, arg_type_specs_length =
+ Ext_list.fold_right
+ (fun (label,ty,attr,loc) (arg_type_specs, arg_types, i) ->
+ let arg_label = Ast_core_type.label_name label in
+ let arg_label, arg_type, new_arg_types =
+ match arg_label with
+ | Optional s ->
-let border = String.length "{j|"
+ let arg_type , new_ty = get_arg_type ~nolabel:false true ty in
+ begin match arg_type with
+ | NonNullString _ ->
+ (* ?x:([`x of int ] [@bs.string]) does not make sense *)
+ Location.raise_errorf
+ ~loc
+ "[@@bs.string] does not work with optional when it has arities in label %s" label
+ | _ ->
+ External_arg_spec.optional s, arg_type,
+ ((label, Ast_core_type.lift_option_type new_ty , attr,loc) :: arg_types) end
+ | Label s ->
+ begin match get_arg_type ~nolabel:false false ty with
+ | (Arg_cst ( i) as arg_type), new_ty ->
+ External_arg_spec.label s (Some i), arg_type, arg_types
+ | arg_type, new_ty ->
+ External_arg_spec.label s None, arg_type, (label, new_ty,attr,loc) :: arg_types
+ end
+ | Empty ->
+ begin match get_arg_type ~nolabel:true false ty with
+ | (Arg_cst ( i) as arg_type), new_ty ->
+ External_arg_spec.empty_lit i , arg_type, arg_types
+ | arg_type, new_ty ->
+ External_arg_spec.empty_label, arg_type, (label, new_ty,attr,loc) :: arg_types
+ end
+ in
+ (if i = 0 && splice then
+ match arg_type with
+ | Array -> ()
+ | _ -> Location.raise_errorf ~loc "[@@@@bs.splice] expect the last type to be an array");
+ ({ External_arg_spec.arg_label ;
+ arg_type
+ } :: arg_type_specs,
+ new_arg_types,
+ if arg_type = Ignore then i
+ else i + 1
+ )
+ ) arg_types_ty
+ (match st with
+ | {val_send_pipe = Some obj; _ } ->
+ let arg_type, new_ty = get_arg_type ~nolabel:true false obj in
+ begin match arg_type with
+ | Arg_cst _ ->
+ Location.raise_errorf ~loc:obj.ptyp_loc "[@bs.as] is not supported in bs.send type "
+ | _ ->
+ (* more error checking *)
+ [External_arg_spec.empty_kind arg_type]
+ ,
+ ["", new_ty, [], obj.ptyp_loc]
+ ,0
+ end
-let aux loc (segment : segment) =
- match segment with
- | {start ; finish; kind ; content}
- ->
- let loc = update border start finish loc in
- begin match kind with
- | String ->
- Exp.constant
- ~loc
- (Const_string (content, escaped))
- | Var ->
- Exp.apply ~loc
- (Exp.ident ~loc {loc ; txt = to_string_ident })
- [
- "",
- Exp.ident ~loc {loc ; txt = Lident content}
- ]
- end
+ | {val_send_pipe = None ; _ } -> [],[], 0) in
+ let ffi : External_ffi_types.attr = match st with
+ | {set_index = true;
-let transform_interp loc s =
- let s_len = String.length s in
- let buf = Buffer.create (s_len * 2 ) in
- try
- let cxt : cxt =
- { segment_start = {lnum = 0; offset = 0; byte_bol = 0};
- buf ;
- s_len;
- segments = [];
- pos_lnum = 0;
- byte_bol = 0;
- pos_bol = 0;
+ val_name = `Nm_na;
+ external_module_name = None ;
+ module_as_val = None;
+ val_send = `Nm_na;
+ val_send_pipe = None;
+ splice = false;
+ scopes ;
+ get_index = false;
+ new_name = `Nm_na;
+ call_name = `Nm_na;
+ set_name = `Nm_na ;
+ get_name = `Nm_na ;
- } in
+ return_wrapper = _;
+ mk_obj = _ ;
- check_and_transform 0 s 0 cxt;
- let rev_segments = cxt.segments in
- match rev_segments with
- | [] ->
- Exp.constant ~loc
- (Const_string ("", Some Literals.escaped_j_delimiter))
- | [ segment] ->
- aux loc segment
- | a::rest ->
- List.fold_left (fun (acc : Parsetree.expression)
- (x : segment) ->
- concat_exp (aux loc x) acc )
- (aux loc a) rest
- with
- Error (start,pos, error)
- ->
- Location.raise_errorf ~loc:(update border start pos loc )
- "%a" pp_error error
+ }
+ ->
+ if String.length prim_name <> 0 then
+ Location.raise_errorf ~loc "[@@bs.set_index] expect external names to be empty string";
+ if arg_type_specs_length = 3 then
+ Js_set_index {js_set_index_scopes = scopes}
+ else
+ Location.raise_errorf ~loc "Ill defined attribute [@@bs.set_index](arity of 3)"
-end
-module Ast_exp : sig
-#1 "ast_exp.mli"
-(* 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. *)
+ | {set_index = true; _}
+ ->
+ Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.set_index]")
-type t = Parsetree.expression
-end = struct
-#1 "ast_exp.ml"
-(* 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. *)
+ | {get_index = true;
-type t = Parsetree.expression
+ val_name = `Nm_na;
+ external_module_name = None ;
+ module_as_val = None;
+ val_send = `Nm_na;
+ val_send_pipe = None;
-end
-module Ast_external_mk : sig
-#1 "ast_external_mk.mli"
-(* 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. *)
+ splice = false;
+ scopes ;
+ new_name = `Nm_na;
+ call_name = `Nm_na;
+ set_name = `Nm_na ;
+ get_name = `Nm_na ;
+ set_index = false;
+ mk_obj;
+ return_wrapper ;
+ } ->
+ if String.length prim_name <> 0 then
+ Location.raise_errorf ~loc "[@@bs.get_index] expect external names to be empty string";
+ if arg_type_specs_length = 2 then
+ Js_get_index {js_get_index_scopes = scopes}
+ else Location.raise_errorf ~loc
+ "Ill defined attribute [@@bs.get_index] (arity expected 2 : while %d)" arg_type_specs_length
-(**
- [local_module loc ~pval_prim ~pval_type args]
- generate such code
- {[
- let module J = struct
- external unsafe_expr : pval_type = pval_prim
- end in
- J.unssafe_expr args
- ]}
-*)
-val local_external : Location.t ->
- ?pval_attributes:Parsetree.attributes ->
- pval_prim:string list ->
- pval_type:Parsetree.core_type ->
- ?local_module_name:string ->
- ?local_fun_name:string ->
- (string * Parsetree.expression) list -> Parsetree.expression_desc
+ | {get_index = true; _}
-val local_extern_cont :
- Location.t ->
- ?pval_attributes:Parsetree.attributes ->
- pval_prim:string list ->
- pval_type:Parsetree.core_type ->
- ?local_module_name:string ->
- ?local_fun_name:string ->
- (Parsetree.expression -> Parsetree.expression) -> Parsetree.expression_desc
+ ->
+ Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.get_index]")
-end = struct
-#1 "ast_external_mk.ml"
-(* 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 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_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 local_extern_cont loc
- ?(pval_attributes=[])
- ~pval_prim
- ~pval_type
- ?(local_module_name = "J")
- ?(local_fun_name = "unsafe_expr")
- (cb : Parsetree.expression -> 'a)
- : 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_attributes };
- pstr_loc = loc;
- }];
- pmod_loc = loc;
- pmod_attributes = []},
- cb {pexp_desc = Pexp_ident {txt = Ldot (Lident local_module_name, local_fun_name);
- loc};
- pexp_attributes = [] ;
- pexp_loc = loc}
-)
-end
-module Ast_pat : sig
-#1 "ast_pat.mli"
-(* 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_as_val = Some external_module_name ;
-type t = Parsetree.pattern
+ get_index = false;
+ val_name ;
+ new_name ;
-val is_unit_cont : yes:'a -> no:'a -> t -> 'a
+ external_module_name = None ;
+ val_send = `Nm_na;
+ val_send_pipe = None;
+ scopes = []; (* module as var does not need scopes *)
+ splice;
+ call_name = `Nm_na;
+ set_name = `Nm_na ;
+ get_name = `Nm_na ;
+ set_index = false;
+ return_wrapper = _;
+ mk_obj = _ ;
+ } ->
+ begin match arg_types_ty, new_name, val_name with
+ | [], `Nm_na, _ -> Js_module_as_var external_module_name
+ | _, `Nm_na, _ -> Js_module_as_fn {splice; external_module_name }
+ | _, #bundle_source, #bundle_source ->
+ Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.module].")
-(** [arity_of_fun pat e] tells the arity of
- expression [fun pat -> e]*)
-val arity_of_fun : t -> Parsetree.expression -> int
+ | _, (`Nm_val _ | `Nm_external _) , `Nm_na
+ -> Js_module_as_class external_module_name
+ | _, `Nm_payload _ , `Nm_na
+ ->
+ Location.raise_errorf ~loc
+ "Incorrect FFI attribute found: (bs.new should not carry a payload here)"
+ end
+ | {module_as_val = Some x; _}
+ ->
+ Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.module].")
+ | {call_name = (`Nm_val name | `Nm_external name | `Nm_payload name) ;
+ splice;
+ scopes ;
+ external_module_name;
-val is_single_variable_pattern_conservative : t -> bool
+ val_name = `Nm_na ;
+ module_as_val = None;
+ val_send = `Nm_na ;
+ val_send_pipe = None;
-end = struct
-#1 "ast_pat.ml"
-(* 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. *)
+ set_index = false;
+ get_index = false;
+ new_name = `Nm_na;
+ set_name = `Nm_na ;
+ get_name = `Nm_na ;
+ mk_obj = _ ;
+ return_wrapper = _ ;
+ } ->
+ Js_call {splice; name; external_module_name; scopes }
+ | {call_name = #bundle_source ; _ }
+ ->
+ Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.val]")
-type t = Parsetree.pattern
+ | {val_name = (`Nm_val name | `Nm_external name | `Nm_payload name);
+ external_module_name;
+ call_name = `Nm_na ;
+ module_as_val = None;
+ val_send = `Nm_na ;
+ val_send_pipe = None;
+ set_index = false;
+ get_index = false;
+ new_name = `Nm_na;
+ set_name = `Nm_na ;
+ get_name = `Nm_na;
+ mk_obj = _;
+ return_wrapper = _;
+ splice = false ;
+ scopes ;
+ }
+ ->
+ Js_global { name; external_module_name; scopes}
+ | {val_name = #bundle_source ; _ }
+ ->
+ Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.val]")
-let is_unit_cont ~yes ~no (p : t) =
- match p with
- | {ppat_desc = Ppat_construct({txt = Lident "()"}, None)}
- -> yes
- | _ -> no
+ | {splice ;
+ scopes ;
+ external_module_name = (Some _ as external_module_name);
+ val_name = `Nm_na ;
+ call_name = `Nm_na ;
+ module_as_val = None;
+ val_send = `Nm_na ;
+ val_send_pipe = None;
+ set_index = false;
+ get_index = false;
+ new_name = `Nm_na;
+ set_name = `Nm_na ;
+ get_name = `Nm_na ;
+ mk_obj = _ ;
+ return_wrapper= _ ;
+ }
+ ->
+ let name = string_of_bundle_source prim_name_or_pval_prim in
+ if arg_type_specs_length = 0 then
+ Js_global { name; external_module_name; scopes}
+ else Js_call {splice; name; external_module_name; scopes}
+ | {val_send = (`Nm_val name | `Nm_external name | `Nm_payload name);
+ splice;
+ scopes;
+ val_send_pipe = None;
+ val_name = `Nm_na ;
+ call_name = `Nm_na ;
+ module_as_val = None;
+ set_index = false;
+ get_index = false;
+ new_name = `Nm_na;
+ set_name = `Nm_na ;
+ get_name = `Nm_na ;
+ external_module_name = None ;
+ mk_obj = _ ;
+ return_wrapper = _ ;
+ } ->
-(** [arity_of_fun pat e] tells the arity of
- expression [fun pat -> e]
-*)
-let arity_of_fun
- (pat : Parsetree.pattern)
- (e : Parsetree.expression) =
- let rec aux (e : Parsetree.expression) =
- match e.pexp_desc with
- | Pexp_fun ("", None, pat, e) ->
- 1 + aux e
- | Pexp_fun _
- -> Location.raise_errorf
- ~loc:e.pexp_loc "Label is not allowed in JS object"
- | _ -> 0 in
- is_unit_cont ~yes:0 ~no:1 pat + aux e
+ (* PR #2162 - since when we assemble arguments the first argument in
+ [@@bs.send] is ignored
+ *)
+ begin match arg_type_specs with
+ | [] ->
+ Location.raise_errorf
+ ~loc "Ill defined attribute [@@bs.send] (at least one argument)"
+ | {arg_type = Arg_cst _ ; arg_label = _} :: _
+ ->
+ Location.raise_errorf
+ ~loc "Ill defined attribute [@@bs.send] (first argument can not be const)"
+ | _ :: _ ->
+ Js_send {splice ; name; js_send_scopes = scopes ; pipe = false}
+ end
+ | {val_send = #bundle_source; _ }
+ -> Location.raise_errorf ~loc "You used an FFI attribute that can't be used with [@@bs.send]"
-let rec is_single_variable_pattern_conservative (p : t ) =
- match p.ppat_desc with
- | Parsetree.Ppat_any
- | Parsetree.Ppat_var _ -> true
- | Parsetree.Ppat_alias (p,_)
- | Parsetree.Ppat_constraint (p, _) ->
- is_single_variable_pattern_conservative p
-
- | _ -> false
+ | {val_send_pipe = Some typ;
+ (* splice = (false as splice); *)
+ val_send = `Nm_na;
+ val_name = `Nm_na ;
+ call_name = `Nm_na ;
+ module_as_val = None;
+ set_index = false;
+ get_index = false;
+ new_name = `Nm_na;
+ set_name = `Nm_na ;
+ get_name = `Nm_na ;
+ external_module_name = None ;
+ mk_obj = _;
+ return_wrapper = _;
+ scopes;
+ splice ;
+ } ->
+ (** can be one argument *)
+ Js_send {splice ;
+ name = string_of_bundle_source prim_name_or_pval_prim;
+ js_send_scopes = scopes;
+ pipe = true}
-end
-module Bs_ast_mapper : sig
-#1 "bs_ast_mapper.mli"
-(***********************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Alain Frisch, LexiFi *)
-(* *)
-(* Copyright 2012 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
+ | {val_send_pipe = Some _ ; _}
+ -> Location.raise_errorf ~loc "conflict attributes found with [@@bs.send.pipe]"
-(** The interface of a -ppx rewriter
+ | {new_name = (`Nm_val name | `Nm_external name | `Nm_payload name);
+ external_module_name;
- A -ppx rewriter is a program that accepts a serialized abstract syntax
- tree and outputs another, possibly modified, abstract syntax tree.
- This module encapsulates the interface between the compiler and
- the -ppx rewriters, handling such details as the serialization format,
- forwarding of command-line flags, and storing state.
+ val_name = `Nm_na ;
+ call_name = `Nm_na ;
+ module_as_val = None;
+ set_index = false;
+ get_index = false;
+ val_send = `Nm_na ;
+ val_send_pipe = None;
+ set_name = `Nm_na ;
+ get_name = `Nm_na ;
+ splice ;
+ scopes;
+ mk_obj = _ ;
+ return_wrapper = _ ;
- {!mapper} allows to implement AST rewriting using open recursion.
- A typical mapper would be based on {!default_mapper}, a deep
- identity mapper, and will fall back on it for handling the syntax it
- does not modify. For example:
+ }
+ -> Js_new {name; external_module_name; splice; scopes}
+ | {new_name = #bundle_source ; _ }
+ ->
+ Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.new]")
- {[
-open Asttypes
-open Parsetree
-open Ast_mapper
-let test_mapper argv =
- { default_mapper with
- expr = fun mapper expr ->
- match expr with
- | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} ->
- Ast_helper.Exp.constant (Const_int 42)
- | other -> default_mapper.expr mapper other; }
+ | {set_name = (`Nm_val name | `Nm_external name | `Nm_payload name);
-let () =
- register "ppx_test" test_mapper]}
+ val_name = `Nm_na ;
+ call_name = `Nm_na ;
+ module_as_val = None;
+ set_index = false;
+ get_index = false;
+ val_send = `Nm_na ;
+ val_send_pipe = None;
+ new_name = `Nm_na ;
+ get_name = `Nm_na ;
+ external_module_name = None;
+ splice = false;
+ mk_obj = _ ;
+ return_wrapper = _;
+ scopes ;
+ }
+ ->
+ if arg_type_specs_length = 2 then
+ Js_set { js_set_scopes = scopes ; js_set_name = name}
+ else Location.raise_errorf ~loc "Ill defined attribute [@@bs.set] (two args required)"
- This -ppx rewriter, which replaces [[%test]] in expressions with
- the constant [42], can be compiled using
- [ocamlc -o ppx_test -I +compiler-libs ocamlcommon.cma ppx_test.ml].
+ | {set_name = #bundle_source; _}
+ -> Location.raise_errorf ~loc "conflict attributes found with [@@bs.set]"
- *)
+ | {get_name = (`Nm_val name | `Nm_external name | `Nm_payload name);
- open Parsetree
-
- (** {2 A generic Parsetree mapper} *)
-
- type mapper = {
- attribute: mapper -> attribute -> attribute;
- attributes: mapper -> attribute list -> attribute list;
- case: mapper -> case -> case;
- cases: mapper -> case list -> case list;
- class_declaration: mapper -> class_declaration -> class_declaration;
- class_description: mapper -> class_description -> class_description;
- class_expr: mapper -> class_expr -> class_expr;
- class_field: mapper -> class_field -> class_field;
- class_signature: mapper -> class_signature -> class_signature;
- class_structure: mapper -> class_structure -> class_structure;
- class_type: mapper -> class_type -> class_type;
- class_type_declaration: mapper -> class_type_declaration
- -> class_type_declaration;
- class_type_field: mapper -> class_type_field -> class_type_field;
- constructor_declaration: mapper -> constructor_declaration
- -> constructor_declaration;
- expr: mapper -> expression -> expression;
- extension: mapper -> extension -> extension;
- extension_constructor: mapper -> extension_constructor
- -> extension_constructor;
- include_declaration: mapper -> include_declaration -> include_declaration;
- include_description: mapper -> include_description -> include_description;
- label_declaration: mapper -> label_declaration -> label_declaration;
- location: mapper -> Location.t -> Location.t;
- module_binding: mapper -> module_binding -> module_binding;
- module_declaration: mapper -> module_declaration -> module_declaration;
- module_expr: mapper -> module_expr -> module_expr;
- module_type: mapper -> module_type -> module_type;
- module_type_declaration: mapper -> module_type_declaration
- -> module_type_declaration;
- open_description: mapper -> open_description -> open_description;
- pat: mapper -> pattern -> pattern;
- payload: mapper -> payload -> payload;
- signature: mapper -> signature -> signature;
- signature_item: mapper -> signature_item -> signature_item;
- structure: mapper -> structure -> structure;
- structure_item: mapper -> structure_item -> structure_item;
- typ: mapper -> core_type -> core_type;
- type_declaration: mapper -> type_declaration -> type_declaration;
- type_extension: mapper -> type_extension -> type_extension;
- type_kind: mapper -> type_kind -> type_kind;
- value_binding: mapper -> value_binding -> value_binding;
-(* XXXXX *)
- value_bindings_rec: mapper -> value_binding list -> value_binding list;
- value_bindings: mapper -> value_binding list -> value_binding list;
-(* XXXXX *)
- value_description: mapper -> value_description -> value_description;
- with_constraint: mapper -> with_constraint -> with_constraint;
- }
- (** A mapper record implements one "method" per syntactic category,
- using an open recursion style: each method takes as its first
- argument the mapper to be applied to children in the syntax
- tree. *)
-
- val default_mapper: mapper
- (** A default mapper, which implements a "deep identity" mapping. *)
-
-end = struct
-#1 "bs_ast_mapper.ml"
-(***********************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Alain Frisch, LexiFi *)
-(* *)
-(* Copyright 2012 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
+ val_name = `Nm_na ;
+ call_name = `Nm_na ;
+ module_as_val = None;
+ set_index = false;
+ get_index = false;
+ val_send = `Nm_na ;
+ val_send_pipe = None;
+ new_name = `Nm_na ;
+ set_name = `Nm_na ;
+ external_module_name = None;
+ splice = false ;
+ mk_obj = _;
+ return_wrapper = _;
+ scopes
+ }
+ ->
+ if arg_type_specs_length = 1 then
+ Js_get { js_get_name = name; js_get_scopes = scopes }
+ else
+ Location.raise_errorf ~loc "Ill defined attribute [@@bs.get] (only one argument)"
+ | {get_name = #bundle_source; _}
+ -> Location.raise_errorf ~loc "Attribute found that conflicts with [@@bs.get]"
-(* A generic Parsetree mapping class *)
-(* Adapted for BUcklescript with more flexibilty*)
+ | {get_name = `Nm_na;
+ val_name = `Nm_na ;
+ call_name = `Nm_na ;
+ module_as_val = None;
+ set_index = false;
+ get_index = false;
+ val_send = `Nm_na ;
+ val_send_pipe = None;
+ new_name = `Nm_na ;
+ set_name = `Nm_na ;
+ external_module_name = None;
+ splice = _ ;
+ scopes = _;
+ mk_obj = _;
+ return_wrapper = _;
-[@@@ocaml.warning "+9"]
-(* Ensure that record patterns don't miss any field. *)
+ }
+ -> Location.raise_errorf ~loc "Could not infer which FFI category it belongs to, maybe you forgot [%@%@bs.val]? " in
+ begin
+ External_ffi_types.check_ffi ~loc ffi;
+ (* result type can not be labeled *)
+ (* currently we don't process attributes of
+ return type, in the future we may *)
+ let new_result_type = result_type in
+ (* get_arg_type ~nolabel:true false result_type in *)
+ let return_wrapper : External_ffi_types.return_wrapper =
+ check_return_wrapper loc st.return_wrapper new_result_type
+ in
+ (
+ Ext_list.fold_right (fun (label,ty,attrs,loc) acc ->
+ Ast_helper.Typ.arrow ~loc ~attrs label ty acc
+ ) new_arg_types_ty new_result_type
+ ) ,
+ prim_name,
+ (Ffi_bs (arg_type_specs,return_wrapper , ffi)), left_attrs
+ end
+let handle_attributes_as_string
+ pval_loc
+ pval_prim
+ (typ : Ast_core_type.t) attrs v =
+ let pval_type, prim_name, ffi, processed_attrs =
+ handle_attributes pval_loc pval_prim typ attrs v in
+ pval_type, [prim_name; External_ffi_types.to_string ffi], processed_attrs
-open Asttypes
-open Parsetree
-open Ast_helper
-open Location
-type mapper = {
- attribute: mapper -> attribute -> attribute;
- attributes: mapper -> attribute list -> attribute list;
- case: mapper -> case -> case;
- cases: mapper -> case list -> case list;
- class_declaration: mapper -> class_declaration -> class_declaration;
- class_description: mapper -> class_description -> class_description;
- class_expr: mapper -> class_expr -> class_expr;
- class_field: mapper -> class_field -> class_field;
- class_signature: mapper -> class_signature -> class_signature;
- class_structure: mapper -> class_structure -> class_structure;
- class_type: mapper -> class_type -> class_type;
- class_type_declaration: mapper -> class_type_declaration
- -> class_type_declaration;
- class_type_field: mapper -> class_type_field -> class_type_field;
- constructor_declaration: mapper -> constructor_declaration
- -> constructor_declaration;
- expr: mapper -> expression -> expression;
- extension: mapper -> extension -> extension;
- extension_constructor: mapper -> extension_constructor
- -> extension_constructor;
- include_declaration: mapper -> include_declaration -> include_declaration;
- include_description: mapper -> include_description -> include_description;
- label_declaration: mapper -> label_declaration -> label_declaration;
- location: mapper -> Location.t -> Location.t;
- module_binding: mapper -> module_binding -> module_binding;
- module_declaration: mapper -> module_declaration -> module_declaration;
- module_expr: mapper -> module_expr -> module_expr;
- module_type: mapper -> module_type -> module_type;
- module_type_declaration: mapper -> module_type_declaration
- -> module_type_declaration;
- open_description: mapper -> open_description -> open_description;
- pat: mapper -> pattern -> pattern;
- payload: mapper -> payload -> payload;
- signature: mapper -> signature -> signature;
- signature_item: mapper -> signature_item -> signature_item;
- structure: mapper -> structure -> structure;
- structure_item: mapper -> structure_item -> structure_item;
- typ: mapper -> core_type -> core_type;
- type_declaration: mapper -> type_declaration -> type_declaration;
- type_extension: mapper -> type_extension -> type_extension;
- type_kind: mapper -> type_kind -> type_kind;
- value_binding: mapper -> value_binding -> value_binding;
-(* XXXX *)
- value_bindings_rec : mapper -> value_binding list -> value_binding list;
- value_bindings : mapper -> value_binding list -> value_binding list;
-(* XXXXX *)
- value_description: mapper -> value_description -> value_description;
- with_constraint: mapper -> with_constraint -> with_constraint;
-}
-let map_fst f (x, y) = (f x, y)
-let map_snd f (x, y) = (x, f y)
-let map_tuple f1 f2 (x, y) = (f1 x, f2 y)
-let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
-let map_opt f = function None -> None | Some x -> Some (f x)
+let pval_prim_of_labels labels =
+ let encoding =
+ let arg_kinds =
+ Ext_list.fold_right
+ (fun {Asttypes.loc ; txt } arg_kinds
+ ->
+ let arg_label = External_arg_spec.label (Lam_methname.translate ~loc txt) None in
+ {External_arg_spec.arg_type = Nothing ;
+ arg_label } :: arg_kinds
+ )
+ labels [] in
+ External_ffi_types.to_string
+ (Ffi_obj_create arg_kinds) in
+ [""; encoding]
-let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt}
-module T = struct
- (* Type expressions for the core language *)
+end
+module Ast_util : sig
+#1 "ast_util.mli"
+(* 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 row_field sub = function
- | Rtag (l, attrs, b, tl) ->
- Rtag (l, sub.attributes sub attrs, b, List.map (sub.typ sub) tl)
- | Rinherit t -> Rinherit (sub.typ sub t)
- let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} =
- let open Typ in
- let loc = sub.location sub loc in
- let attrs = sub.attributes sub attrs in
- match desc with
- | Ptyp_any -> any ~loc ~attrs ()
- | Ptyp_var s -> var ~loc ~attrs s
- | Ptyp_arrow (lab, t1, t2) ->
- arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2)
- | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl)
- | Ptyp_constr (lid, tl) ->
- constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
- | Ptyp_object (l, o) ->
- let f (s, a, t) = (s, sub.attributes sub a, sub.typ sub t) in
- object_ ~loc ~attrs (List.map f l) o
- | Ptyp_class (lid, tl) ->
- class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
- | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s
- | Ptyp_variant (rl, b, ll) ->
- variant ~loc ~attrs (List.map (row_field sub) rl) b ll
- | Ptyp_poly (sl, t) -> poly ~loc ~attrs sl (sub.typ sub t)
- | Ptyp_package (lid, l) ->
- package ~loc ~attrs (map_loc sub lid)
- (List.map (map_tuple (map_loc sub) (sub.typ sub)) l)
- | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x)
+type args = (string * Parsetree.expression) list
+type loc = Location.t
+type label_exprs = (Longident.t Asttypes.loc * Parsetree.expression) list
+type 'a cxt = loc -> Bs_ast_mapper.mapper -> 'a
- let map_type_declaration sub
- {ptype_name; ptype_params; ptype_cstrs;
- ptype_kind;
- ptype_private;
- ptype_manifest;
- ptype_attributes;
- ptype_loc} =
- Type.mk (map_loc sub ptype_name)
- ~params:(List.map (map_fst (sub.typ sub)) ptype_params)
- ~priv:ptype_private
- ~cstrs:(List.map
- (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub))
- ptype_cstrs)
- ~kind:(sub.type_kind sub ptype_kind)
- ?manifest:(map_opt (sub.typ sub) ptype_manifest)
- ~loc:(sub.location sub ptype_loc)
- ~attrs:(sub.attributes sub ptype_attributes)
+(** In general three kinds of ast generation.
+ - convert a curried to type to uncurried
+ - convert a curried fun to uncurried fun
+ - convert a uncuried application to normal
+*)
+type uncurry_expression_gen =
+ (Parsetree.pattern ->
+ Parsetree.expression ->
+ Parsetree.expression_desc) cxt
+type uncurry_type_gen =
+ (string -> (* label for error checking *)
+ Parsetree.core_type ->
+ Parsetree.core_type ->
+ Parsetree.core_type) cxt
- let map_type_kind sub = function
- | Ptype_abstract -> Ptype_abstract
- | Ptype_variant l ->
- Ptype_variant (List.map (sub.constructor_declaration sub) l)
- | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l)
- | Ptype_open -> Ptype_open
+(** TODO: the interface is not reusable, it depends on too much context *)
+(** syntax: {[f arg0 arg1 [@bs]]}*)
+val uncurry_fn_apply :
+ (Parsetree.expression ->
+ args ->
+ Parsetree.expression_desc ) cxt
- let map_type_extension sub
- {ptyext_path; ptyext_params;
- ptyext_constructors;
- ptyext_private;
- ptyext_attributes} =
- Te.mk
- (map_loc sub ptyext_path)
- (List.map (sub.extension_constructor sub) ptyext_constructors)
- ~params:(List.map (map_fst (sub.typ sub)) ptyext_params)
- ~priv:ptyext_private
- ~attrs:(sub.attributes sub ptyext_attributes)
+(** syntax : {[f## arg0 arg1 ]}*)
+val method_apply :
+ (Parsetree.expression ->
+ string ->
+ args ->
+ Parsetree.expression_desc) cxt
- let map_extension_constructor_kind sub = function
- Pext_decl(ctl, cto) ->
- Pext_decl(List.map (sub.typ sub) ctl, map_opt (sub.typ sub) cto)
- | Pext_rebind li ->
- Pext_rebind (map_loc sub li)
+(** syntax {[f#@ arg0 arg1 ]}*)
+val property_apply :
+ (Parsetree.expression ->
+ string ->
+ args ->
+ Parsetree.expression_desc) cxt
- let map_extension_constructor sub
- {pext_name;
- pext_kind;
- pext_loc;
- pext_attributes} =
- Te.constructor
- (map_loc sub pext_name)
- (map_extension_constructor_kind sub pext_kind)
- ~loc:(sub.location sub pext_loc)
- ~attrs:(sub.attributes sub pext_attributes)
-end
+(**
+ [function] can only take one argument, that is the reason we did not adopt it
+ syntax:
+ {[ fun [@bs] pat pat1-> body ]}
+ [to_uncurry_fn (fun pat -> (fun pat1 -> ... body))]
-module CT = struct
- (* Type expressions for the class language *)
+*)
+val to_uncurry_fn : uncurry_expression_gen
- let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} =
- let open Cty in
- let loc = sub.location sub loc in
- let attrs = sub.attributes sub attrs in
- match desc with
- | Pcty_constr (lid, tys) ->
- constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys)
- | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x)
- | Pcty_arrow (lab, t, ct) ->
- arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct)
- | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x)
- let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs}
- =
- let open Ctf in
- let loc = sub.location sub loc in
- let attrs = sub.attributes sub attrs in
- match desc with
- | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct)
- | Pctf_val (s, m, v, t) -> val_ ~loc ~attrs s m v (sub.typ sub t)
- | Pctf_method (s, p, v, t) -> method_ ~loc ~attrs s p v (sub.typ sub t)
- | Pctf_constraint (t1, t2) ->
- constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2)
- | Pctf_attribute x -> attribute ~loc (sub.attribute sub x)
- | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x)
+(** syntax:
+ {[fun [@bs.this] obj pat pat1 -> body]}
+*)
+val to_method_callback : uncurry_expression_gen
- let map_signature sub {pcsig_self; pcsig_fields} =
- Csig.mk
- (sub.typ sub pcsig_self)
- (List.map (sub.class_type_field sub) pcsig_fields)
-end
-module MT = struct
- (* Type expressions for the module language *)
+(** syntax :
+ {[ int -> int -> int [@bs]]}
+*)
+val to_uncurry_type : uncurry_type_gen
+
- let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} =
- let open Mty in
- let loc = sub.location sub loc in
- let attrs = sub.attributes sub attrs in
- match desc with
- | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s)
- | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s)
- | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg)
- | Pmty_functor (s, mt1, mt2) ->
- functor_ ~loc ~attrs (map_loc sub s)
- (Misc.may_map (sub.module_type sub) mt1)
- (sub.module_type sub mt2)
- | Pmty_with (mt, l) ->
- with_ ~loc ~attrs (sub.module_type sub mt)
- (List.map (sub.with_constraint sub) l)
- | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me)
- | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x)
+(** syntax
+ {[ method : int -> itn -> int ]}
+*)
+val to_method_type : uncurry_type_gen
- let map_with_constraint sub = function
- | Pwith_type (lid, d) ->
- Pwith_type (map_loc sub lid, sub.type_declaration sub d)
- | Pwith_module (lid, lid2) ->
- Pwith_module (map_loc sub lid, map_loc sub lid2)
- | Pwith_typesubst d -> Pwith_typesubst (sub.type_declaration sub d)
- | Pwith_modsubst (s, lid) ->
- Pwith_modsubst (map_loc sub s, map_loc sub lid)
+(** syntax:
+ {[ 'obj -> int -> int [@bs.this] ]}
+*)
+val to_method_callback_type : uncurry_type_gen
- let map_signature_item sub {psig_desc = desc; psig_loc = loc} =
- let open Sig in
- let loc = sub.location sub loc in
- match desc with
- | Psig_value vd -> value ~loc (sub.value_description sub vd)
- | Psig_type l -> type_ ~loc (List.map (sub.type_declaration sub) l)
- | Psig_typext te -> type_extension ~loc (sub.type_extension sub te)
- | Psig_exception ed -> exception_ ~loc (sub.extension_constructor sub ed)
- | Psig_module x -> module_ ~loc (sub.module_declaration sub x)
- | Psig_recmodule l ->
- rec_module ~loc (List.map (sub.module_declaration sub) l)
- | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x)
- | Psig_open x -> open_ ~loc (sub.open_description sub x)
- | Psig_include x -> include_ ~loc (sub.include_description sub x)
- | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l)
- | Psig_class_type l ->
- class_type ~loc (List.map (sub.class_type_declaration sub) l)
- | Psig_extension (x, attrs) ->
- extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs)
- | Psig_attribute x -> attribute ~loc (sub.attribute sub x)
-end
-module M = struct
- (* Value expressions for the module language *)
- let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} =
- let open Mod in
- let loc = sub.location sub loc in
- let attrs = sub.attributes sub attrs in
- match desc with
- | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x)
- | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str)
- | Pmod_functor (arg, arg_ty, body) ->
- functor_ ~loc ~attrs (map_loc sub arg)
- (Misc.may_map (sub.module_type sub) arg_ty)
- (sub.module_expr sub body)
- | Pmod_apply (m1, m2) ->
- apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2)
- | Pmod_constraint (m, mty) ->
- constraint_ ~loc ~attrs (sub.module_expr sub m)
- (sub.module_type sub mty)
- | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e)
- | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x)
- let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} =
- let open Str in
- let loc = sub.location sub loc in
- match desc with
- | Pstr_eval (x, attrs) ->
- eval ~loc ~attrs:(sub.attributes sub attrs) (sub.expr sub x)
- | Pstr_value (r, vbs) ->
-(* XXX *)
-(* value ~loc r (List.map (sub.value_binding sub) vbs) *)
- value ~loc r
- ((if r = Recursive then sub.value_bindings_rec else sub.value_bindings)
- sub vbs)
-(* XXX *)
- | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd)
- | Pstr_type l -> type_ ~loc (List.map (sub.type_declaration sub) l)
- | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te)
- | Pstr_exception ed -> exception_ ~loc (sub.extension_constructor sub ed)
- | Pstr_module x -> module_ ~loc (sub.module_binding sub x)
- | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l)
- | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x)
- | Pstr_open x -> open_ ~loc (sub.open_description sub x)
- | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l)
- | Pstr_class_type l ->
- class_type ~loc (List.map (sub.class_type_declaration sub) l)
- | Pstr_include x -> include_ ~loc (sub.include_declaration sub x)
- | Pstr_extension (x, attrs) ->
- extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs)
- | Pstr_attribute x -> attribute ~loc (sub.attribute sub x)
-end
+val record_as_js_object :
+ (label_exprs ->
+ Parsetree.expression_desc) cxt
-module E = struct
- (* Value expressions for the core language *)
+val js_property :
+ loc ->
+ Parsetree.expression -> string -> Parsetree.expression_desc
- let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} =
- let open Exp in
- let loc = sub.location sub loc in
- let attrs = sub.attributes sub attrs in
- match desc with
- | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x)
- | Pexp_constant x -> constant ~loc ~attrs x
- | Pexp_let (r, vbs, e) ->
-(* XXXX *)
- (* let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs)
- (sub.expr sub e) *)
- let_ ~loc ~attrs r
- (
- (if r = Recursive then sub.value_bindings_rec else sub.value_bindings)
- sub vbs
- )
- (sub.expr sub e)
-(* XXXX *)
- | Pexp_fun (lab, def, p, e) ->
- fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p)
- (sub.expr sub e)
- | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel)
- | Pexp_apply (e, l) ->
- apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l)
- | Pexp_match (e, pel) ->
- match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
- | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
- | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el)
- | Pexp_construct (lid, arg) ->
- construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg)
- | Pexp_variant (lab, eo) ->
- variant ~loc ~attrs lab (map_opt (sub.expr sub) eo)
- | Pexp_record (l, eo) ->
- record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l)
- (map_opt (sub.expr sub) eo)
- | Pexp_field (e, lid) ->
- field ~loc ~attrs (sub.expr sub e) (map_loc sub lid)
- | Pexp_setfield (e1, lid, e2) ->
- setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid)
- (sub.expr sub e2)
- | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el)
- | Pexp_ifthenelse (e1, e2, e3) ->
- ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
- (map_opt (sub.expr sub) e3)
- | Pexp_sequence (e1, e2) ->
- sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
- | Pexp_while (e1, e2) ->
- while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
- | Pexp_for (p, e1, e2, d, e3) ->
- for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d
- (sub.expr sub e3)
- | Pexp_coerce (e, t1, t2) ->
- coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1)
- (sub.typ sub t2)
- | Pexp_constraint (e, t) ->
- constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t)
- | Pexp_send (e, s) -> send ~loc ~attrs (sub.expr sub e) s
- | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid)
- | Pexp_setinstvar (s, e) ->
- setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e)
- | Pexp_override sel ->
- override ~loc ~attrs
- (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel)
- | Pexp_letmodule (s, me, e) ->
- letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me)
- (sub.expr sub e)
- | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e)
- | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e)
- | Pexp_poly (e, t) ->
- poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t)
- | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls)
- | Pexp_newtype (s, e) -> newtype ~loc ~attrs s (sub.expr sub e)
- | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me)
- | Pexp_open (ovf, lid, e) ->
- open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e)
- | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x)
-end
+val handle_debugger :
+ loc -> Ast_payload.t -> Parsetree.expression_desc
-module P = struct
- (* Patterns *)
+val handle_raw :
+ ?check_js_regex: bool -> loc -> Ast_payload.t -> Parsetree.expression
- let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} =
- let open Pat in
- let loc = sub.location sub loc in
- let attrs = sub.attributes sub attrs in
- match desc with
- | Ppat_any -> any ~loc ~attrs ()
- | Ppat_var s -> var ~loc ~attrs (map_loc sub s)
- | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s)
- | Ppat_constant c -> constant ~loc ~attrs c
- | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2
- | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl)
- | Ppat_construct (l, p) ->
- construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p)
- | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p)
- | Ppat_record (lpl, cf) ->
- record ~loc ~attrs
- (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf
- | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl)
- | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2)
- | Ppat_constraint (p, t) ->
- constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t)
- | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s)
- | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p)
- | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s)
- | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p)
- | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x)
-end
+val handle_external :
+ loc -> string -> Parsetree.expression
+
+val handle_raw_structure :
+ loc -> Ast_payload.t -> Parsetree.structure_item
-module CE = struct
- (* Value expressions for the class language *)
+val ocaml_obj_as_js_object :
+ (Parsetree.pattern ->
+ Parsetree.class_field list ->
+ Parsetree.expression_desc) cxt
- let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} =
- let open Cl in
- let loc = sub.location sub loc in
- let attrs = sub.attributes sub attrs in
- match desc with
- | Pcl_constr (lid, tys) ->
- constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys)
- | Pcl_structure s ->
- structure ~loc ~attrs (sub.class_structure sub s)
- | Pcl_fun (lab, e, p, ce) ->
- fun_ ~loc ~attrs lab
- (map_opt (sub.expr sub) e)
- (sub.pat sub p)
- (sub.class_expr sub ce)
- | Pcl_apply (ce, l) ->
- apply ~loc ~attrs (sub.class_expr sub ce)
- (List.map (map_snd (sub.expr sub)) l)
- | Pcl_let (r, vbs, ce) ->
-(* XXXX *)
- (* let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs)
- (sub.class_expr sub ce) *)
- let_ ~loc ~attrs r
- ((if r = Recursive then sub.value_bindings_rec else sub.value_bindings)
- sub vbs)
- (sub.class_expr sub ce)
-(* XXXX *)
- | Pcl_constraint (ce, ct) ->
- constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct)
- | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x)
- let map_kind sub = function
- | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e)
- | Cfk_virtual t -> Cfk_virtual (sub.typ sub t)
+ val convertBsErrorFunction :
+
+ (Ast_helper.attrs -> Parsetree.case list -> Parsetree.expression) cxt
- let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} =
- let open Cf in
- let loc = sub.location sub loc in
- let attrs = sub.attributes sub attrs in
- match desc with
- | Pcf_inherit (o, ce, s) -> inherit_ ~loc ~attrs o (sub.class_expr sub ce) s
- | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k)
- | Pcf_method (s, p, k) ->
- method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k)
- | Pcf_constraint (t1, t2) ->
- constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2)
- | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e)
- | Pcf_attribute x -> attribute ~loc (sub.attribute sub x)
- | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x)
+end = struct
+#1 "ast_util.ml"
+(* 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 map_structure sub {pcstr_self; pcstr_fields} =
- {
- pcstr_self = sub.pat sub pcstr_self;
- pcstr_fields = List.map (sub.class_field sub) pcstr_fields;
- }
+open Ast_helper
+type 'a cxt = Ast_helper.loc -> Bs_ast_mapper.mapper -> 'a
+type loc = Location.t
+type args = (string * Parsetree.expression) list
+type label_exprs = (Longident.t Asttypes.loc * Parsetree.expression) list
+type uncurry_expression_gen =
+ (Parsetree.pattern ->
+ Parsetree.expression ->
+ Parsetree.expression_desc) cxt
+type uncurry_type_gen =
+ (string ->
+ Parsetree.core_type ->
+ Parsetree.core_type ->
+ Parsetree.core_type) cxt
- let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr;
- pci_loc; pci_attributes} =
- Ci.mk
- ~virt:pci_virt
- ~params:(List.map (map_fst (sub.typ sub)) pl)
- (map_loc sub pci_name)
- (f pci_expr)
- ~loc:(sub.location sub pci_loc)
- ~attrs:(sub.attributes sub pci_attributes)
-end
+let uncurry_type_id =
+ Ast_literal.Lid.js_fn
-(* Now, a generic AST mapper, to be extended to cover all kinds and
- cases of the OCaml grammar. The default behavior of the mapper is
- the identity. *)
+let method_id =
+ Ast_literal.Lid.js_meth
-let default_mapper =
- {
- structure = (fun this l -> List.map (this.structure_item this) l);
- structure_item = M.map_structure_item;
- module_expr = M.map;
- signature = (fun this l -> List.map (this.signature_item this) l);
- signature_item = MT.map_signature_item;
- module_type = MT.map;
- with_constraint = MT.map_with_constraint;
- class_declaration =
- (fun this -> CE.class_infos this (this.class_expr this));
- class_expr = CE.map;
- class_field = CE.map_field;
- class_structure = CE.map_structure;
- class_type = CT.map;
- class_type_field = CT.map_field;
- class_signature = CT.map_signature;
- class_type_declaration =
- (fun this -> CE.class_infos this (this.class_type this));
- class_description =
- (fun this -> CE.class_infos this (this.class_type this));
- type_declaration = T.map_type_declaration;
- type_kind = T.map_type_kind;
- typ = T.map;
- type_extension = T.map_type_extension;
- extension_constructor = T.map_extension_constructor;
- value_description =
- (fun this {pval_name; pval_type; pval_prim; pval_loc;
- pval_attributes} ->
- Val.mk
- (map_loc this pval_name)
- (this.typ this pval_type)
- ~attrs:(this.attributes this pval_attributes)
- ~loc:(this.location this pval_loc)
- ~prim:pval_prim
- );
+let method_call_back_id =
+ Ast_literal.Lid.js_meth_callback
- pat = P.map;
- expr = E.map;
+let arity_lit = "Arity_"
- module_declaration =
- (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} ->
- Md.mk
- (map_loc this pmd_name)
- (this.module_type this pmd_type)
- ~attrs:(this.attributes this pmd_attributes)
- ~loc:(this.location this pmd_loc)
- );
-
- module_type_declaration =
- (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} ->
- Mtd.mk
- (map_loc this pmtd_name)
- ?typ:(map_opt (this.module_type this) pmtd_type)
- ~attrs:(this.attributes this pmtd_attributes)
- ~loc:(this.location this pmtd_loc)
- );
-
- module_binding =
- (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} ->
- Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr)
- ~attrs:(this.attributes this pmb_attributes)
- ~loc:(this.location this pmb_loc)
- );
-
-
- open_description =
- (fun this {popen_lid; popen_override; popen_attributes; popen_loc} ->
- Opn.mk (map_loc this popen_lid)
- ~override:popen_override
- ~loc:(this.location this popen_loc)
- ~attrs:(this.attributes this popen_attributes)
- );
+let mk_args loc n tys =
+ Typ.variant ~loc
+ [ Rtag (arity_lit ^ string_of_int n, [], (n = 0), tys)] Closed None
+let generic_lift txt loc args result =
+ let xs =
+ match args with
+ | [ ] -> [mk_args loc 0 [] ; result ]
+ | [ x ] -> [ mk_args loc 1 [x] ; result ]
+ | _ ->
+ [mk_args loc (List.length args ) [Typ.tuple ~loc args] ; result ]
+ in
+ Typ.constr ~loc {txt ; loc} xs
- include_description =
- (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
- Incl.mk (this.module_type this pincl_mod)
- ~loc:(this.location this pincl_loc)
- ~attrs:(this.attributes this pincl_attributes)
- );
+let lift_curry_type loc =
+ generic_lift uncurry_type_id loc
- include_declaration =
- (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
- Incl.mk (this.module_expr this pincl_mod)
- ~loc:(this.location this pincl_loc)
- ~attrs:(this.attributes this pincl_attributes)
- );
+let lift_method_type loc =
+ generic_lift method_id loc
- value_bindings = (fun this vbs ->
- match vbs with
- | [vb] -> [ this.value_binding this vb ]
- | _ -> List.map (this.value_binding this) vbs
- );
- value_bindings_rec = (fun this vbs ->
- match vbs with
- | [vb] -> [ this.value_binding this vb ]
- | _ -> List.map (this.value_binding this) vbs
- );
- value_binding =
- (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} ->
- Vb.mk
- (this.pat this pvb_pat)
- (this.expr this pvb_expr)
- ~loc:(this.location this pvb_loc)
- ~attrs:(this.attributes this pvb_attributes)
- );
+let lift_js_method_callback loc
+ =
+ generic_lift method_call_back_id loc
+(** Note that currently there is no way to consume [Js.meth_callback]
+ so it is fine to encode it with a freedom,
+ but we need make it better for error message.
+ - all are encoded as
+ {[
+ type fn = (`Args_n of _ , 'result ) Js.fn
+ type method = (`Args_n of _, 'result) Js.method
+ type method_callback = (`Args_n of _, 'result) Js.method_callback
+ ]}
+ For [method_callback], the arity is never zero, so both [method]
+ and [fn] requires (unit -> 'a) to encode arity zero
+*)
- constructor_declaration =
- (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} ->
- Type.constructor
- (map_loc this pcd_name)
- ~args:(List.map (this.typ this) pcd_args)
- ?res:(map_opt (this.typ this) pcd_res)
- ~loc:(this.location this pcd_loc)
- ~attrs:(this.attributes this pcd_attributes)
- );
- label_declaration =
- (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} ->
- Type.field
- (map_loc this pld_name)
- (this.typ this pld_type)
- ~mut:pld_mutable
- ~loc:(this.location this pld_loc)
- ~attrs:(this.attributes this pld_attributes)
- );
+let arrow = Typ.arrow
- cases = (fun this l -> List.map (this.case this) l);
- case =
- (fun this {pc_lhs; pc_guard; pc_rhs} ->
- {
- pc_lhs = this.pat this pc_lhs;
- pc_guard = map_opt (this.expr this) pc_guard;
- pc_rhs = this.expr this pc_rhs;
- }
- );
+let js_property loc obj name =
+ Parsetree.Pexp_send
+ ((Exp.apply ~loc
+ (Exp.ident ~loc
+ {loc;
+ txt = Ldot (Ast_literal.Lid.js_unsafe, Literals.unsafe_downgrade)})
+ ["",obj]), name)
+(* TODO:
+ have a final checking for property arities
+ [#=],
+*)
- location = (fun this l -> l);
- extension = (fun this (s, e) -> (map_loc this s, this.payload this e));
- attribute = (fun this (s, e) -> (map_loc this s, this.payload this e));
- attributes = (fun this l -> List.map (this.attribute this) l);
- payload =
- (fun this -> function
- | PStr x -> PStr (this.structure this x)
- | PTyp x -> PTyp (this.typ this x)
- | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g)
- );
- }
-end
-module External_ffi_types : sig
-#1 "external_ffi_types.mli"
-(* 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 generic_apply kind loc
+ (self : Bs_ast_mapper.mapper)
+ (obj : Parsetree.expression)
+ (args : args ) cb =
+ let obj = self.expr self obj in
+ let args =
+ Ext_list.map (fun (label,e) ->
+ if label <> "" then
+ Bs_syntaxerr.err loc Label_in_uncurried_bs_attribute;
+ self.expr self e
+ ) args in
+ let len = List.length args in
+ let arity, fn, args =
+ match args with
+ | [ {pexp_desc =
+ Pexp_construct ({txt = Lident "()"}, None)}]
+ ->
+ 0, cb loc obj, []
+ | _ ->
+ len, cb loc obj, args in
+ if arity < 10 then
+ let txt =
+ match kind with
+ | `Fn | `PropertyFn ->
+ Longident.Ldot (Ast_literal.Lid.js_unsafe,
+ Literals.fn_run ^ string_of_int arity)
+ | `Method ->
+ Longident.Ldot(Ast_literal.Lid.js_unsafe,
+ Literals.method_run ^ string_of_int arity
+ ) in
+ Parsetree.Pexp_apply (Exp.ident {txt ; loc}, ("",fn) :: Ext_list.map (fun x -> "",x) args)
+ else
+ let fn_type, args_type, result_type = Ast_comb.tuple_type_pair ~loc `Run arity in
+ let string_arity = string_of_int arity in
+ let pval_prim, pval_type =
+ match kind with
+ | `Fn | `PropertyFn ->
+ ["#fn_run"; string_arity],
+ arrow ~loc "" (lift_curry_type loc args_type result_type ) fn_type
+ | `Method ->
+ ["#method_run" ; string_arity],
+ arrow ~loc "" (lift_method_type loc args_type result_type) fn_type
+ in
+ Ast_external_mk.local_external loc ~pval_prim ~pval_type
+ (("", fn) :: Ext_list.map (fun x -> "",x) args )
-type module_bind_name =
- | Phint_name of string
- (* explicit hint name *)
- | Phint_nothing
-type external_module_name =
- { bundle : string ;
- module_bind_name : module_bind_name
- }
+let uncurry_fn_apply loc self fn args =
+ generic_apply `Fn loc self fn args (fun _ obj -> obj )
-type pipe = bool
-type js_call = {
- name : string;
- external_module_name : external_module_name option;
- splice : bool ;
- scopes : string list
-}
+let property_apply loc self obj name (args : args)
+ = generic_apply `PropertyFn loc self obj args
+ (fun loc obj -> Exp.mk ~loc (js_property loc obj name))
-type js_send = {
- name : string ;
- splice : bool ;
- pipe : pipe ;
- js_send_scopes : string list;
-} (* we know it is a js send, but what will happen if you pass an ocaml objct *)
+let method_apply loc self obj name args =
+ generic_apply `Method loc self obj args
+ (fun loc obj -> Exp.mk ~loc (js_property loc obj name))
-type js_global_val = {
- name : string ;
- external_module_name : external_module_name option;
- scopes : string list
-}
+let generic_to_uncurry_type kind loc (mapper : Bs_ast_mapper.mapper) label
+ (first_arg : Parsetree.core_type)
+ (typ : Parsetree.core_type) =
+ if label <> "" then
+ Bs_syntaxerr.err loc Label_in_uncurried_bs_attribute;
-type js_new_val = {
- name : string ;
- external_module_name : external_module_name option;
- splice : bool ;
- scopes : string list;
-}
+ let rec aux acc (typ : Parsetree.core_type) =
+ (* in general,
+ we should collect [typ] in [int -> typ] before transformation,
+ however: when attributes [bs] and [bs.this] found in typ,
+ we should stop
+ *)
+ match Ast_attributes.process_attributes_rev typ.ptyp_attributes with
+ | `Nothing, _ ->
+ begin match typ.ptyp_desc with
+ | Ptyp_arrow (label, arg, body)
+ ->
+ if label <> "" then
+ Bs_syntaxerr.err typ.ptyp_loc Label_in_uncurried_bs_attribute;
+ aux (mapper.typ mapper arg :: acc) body
+ | _ -> mapper.typ mapper typ, acc
+ end
+ | _, _ -> mapper.typ mapper typ, acc
+ in
+ let first_arg = mapper.typ mapper first_arg in
+ let result, rev_extra_args = aux [first_arg] typ in
+ let args = List.rev rev_extra_args in
+ let filter_args args =
+ match args with
+ | [{Parsetree.ptyp_desc =
+ (Ptyp_constr ({txt = Lident "unit"}, [])
+ )}]
+ -> []
+ | _ -> args in
+ match kind with
+ | `Fn ->
+ let args = filter_args args in
+ lift_curry_type loc args result
+ | `Method ->
+ let args = filter_args args in
+ lift_method_type loc args result
-type js_module_as_fn =
- { external_module_name : external_module_name;
- splice : bool
- }
+ | `Method_callback
+ -> lift_js_method_callback loc args result
-type arg_type = External_arg_spec.attr
-type arg_label = External_arg_spec.label
+let to_uncurry_type =
+ generic_to_uncurry_type `Fn
+let to_method_type =
+ generic_to_uncurry_type `Method
+let to_method_callback_type =
+ generic_to_uncurry_type `Method_callback
+let generic_to_uncurry_exp kind loc (self : Bs_ast_mapper.mapper) pat body
+ =
+ let rec aux acc (body : Parsetree.expression) =
+ match Ast_attributes.process_attributes_rev body.pexp_attributes with
+ | `Nothing, _ ->
+ begin match body.pexp_desc with
+ | Pexp_fun (label,_, arg, body)
+ ->
+ if label <> "" then
+ Bs_syntaxerr.err loc Label_in_uncurried_bs_attribute;
+ aux (self.pat self arg :: acc) body
+ | _ -> self.expr self body, acc
+ end
+ | _, _ -> self.expr self body, acc
+ in
+ let first_arg = self.pat self pat in
+ let () =
+ match kind with
+ | `Method_callback ->
+ if not @@ Ast_pat.is_single_variable_pattern_conservative first_arg then
+ Bs_syntaxerr.err first_arg.ppat_loc Bs_this_simple_pattern
+ | _ -> ()
+ in
-type obj_create = External_arg_spec.t list
+ let result, rev_extra_args = aux [first_arg] body in
+ let body =
+ List.fold_left (fun e p -> Ast_comb.fun_no_label ~loc p e )
+ result rev_extra_args in
+ let len = List.length rev_extra_args in
+ let arity =
+ match kind with
+ | `Fn ->
+ begin match rev_extra_args with
+ | [ p]
+ ->
+ Ast_pat.is_unit_cont ~yes:0 ~no:len p
-type js_get =
- { js_get_name : string ;
- js_get_scopes : string list;
- }
+ | _ -> len
+ end
+ | `Method_callback -> len in
+ if arity < 10 then
+ let txt =
+ match kind with
+ | `Fn ->
+ Longident.Ldot ( Ast_literal.Lid.js_unsafe, Literals.fn_mk ^ string_of_int arity)
+ | `Method_callback ->
+ Longident.Ldot (Ast_literal.Lid.js_unsafe, Literals.fn_method ^ string_of_int arity) in
+ Parsetree.Pexp_apply (Exp.ident {txt;loc} , ["",body])
-type js_set =
- { js_set_name : string ;
- js_set_scopes : string list
- }
+ else
+ let pval_prim =
+ [ (match kind with
+ | `Fn -> "#fn_mk"
+ | `Method_callback -> "#fn_method");
+ string_of_int arity] in
+ let fn_type , args_type, result_type = Ast_comb.tuple_type_pair ~loc `Make arity in
+ let pval_type = arrow ~loc "" fn_type (
+ match kind with
+ | `Fn ->
+ lift_curry_type loc args_type result_type
+ | `Method_callback ->
+ lift_js_method_callback loc args_type result_type
+ ) in
+ Ast_external_mk.local_extern_cont loc ~pval_prim ~pval_type
+ (fun prim -> Exp.apply ~loc prim ["", body])
+let to_uncurry_fn =
+ generic_to_uncurry_exp `Fn
+let to_method_callback =
+ generic_to_uncurry_exp `Method_callback
-type js_get_index = {
- js_get_index_scopes : string list
-}
-type js_set_index = {
- js_set_index_scopes : string list
-}
+let handle_debugger loc payload =
+ if Ast_payload.as_empty_structure payload then
+ Parsetree.Pexp_apply
+ (Exp.ident {txt = Ldot(Ast_literal.Lid.js_unsafe, Literals.debugger ); loc},
+ ["", Ast_literal.val_unit ~loc ()])
+ else Location.raise_errorf ~loc "bs.raw can only be applied to a string"
+let handle_raw ?(check_js_regex = false) loc payload =
+ begin match Ast_payload.as_string_exp ~check_js_regex payload with
+ | Not_String_Lteral ->
+ Location.raise_errorf ~loc
+ "bs.raw can only be applied to a string"
+ | Ast_payload.JS_Regex_Check_Failed ->
+ Location.raise_errorf ~loc "this is an invalid js regex"
+ | Correct exp ->
+ let pexp_desc =
+ Parsetree.Pexp_apply (
+ Exp.ident {loc;
+ txt =
+ Ldot (Ast_literal.Lid.js_unsafe,
+ Literals.raw_expr)},
+ ["",exp]
+ )
+ in
+ { exp with pexp_desc }
+ end
-type attr =
- | Js_global of js_global_val
- | Js_module_as_var of external_module_name
- | Js_module_as_fn of js_module_as_fn
- | Js_module_as_class of external_module_name
- | Js_call of js_call
- | Js_send of js_send
- | Js_new of js_new_val
- | Js_set of js_set
- | Js_get of js_get
- | Js_get_index of js_get_index
- | Js_set_index of js_set_index
+let handle_external loc x =
+ let raw_exp : Ast_exp.t =
+ Ast_helper.Exp.apply
+ (Exp.ident ~loc
+ {loc; txt = Ldot (Ast_literal.Lid.js_unsafe,
+ Literals.raw_expr)})
+ ~loc
+ [Ext_string.empty,
+ Exp.constant ~loc (Const_string (x,Some Ext_string.empty))] in
+ let empty =
+ Exp.ident ~loc
+ {txt = Ldot (Ldot(Lident"Js", "Undefined"), "empty");loc}
+ in
+ let undefined_typeof =
+ Exp.ident {loc ; txt = Ldot(Lident "Js","undefinedToOption")} in
+ let typeof =
+ Exp.ident {loc ; txt = Ldot(Lident "Js","typeof")} in
-type return_wrapper =
- | Return_unset
- | Return_identity
- | Return_undefined_to_opt
- | Return_null_to_opt
- | Return_null_undefined_to_opt
- | Return_to_ocaml_bool
- | Return_replaced_with_unit
+ Exp.apply ~loc undefined_typeof [
+ Ext_string.empty,
+ Exp.ifthenelse ~loc
+ (Exp.apply ~loc
+ (Exp.ident ~loc {loc ; txt = Ldot (Lident "Pervasives", "=")} )
+ [
+ Ext_string.empty,
+ (Exp.apply ~loc typeof [Ext_string.empty,raw_exp]);
+ Ext_string.empty,
+ Exp.constant ~loc (Const_string ("undefined",None))
+ ])
+ (empty)
+ (Some raw_exp)
+ ]
-type t =
- | Ffi_bs of
- External_arg_spec.t list *
- return_wrapper * attr
- | Ffi_obj_create of obj_create
- | Ffi_normal
- (* When it's normal, it is handled as normal c functional ffi call *)
+let handle_raw_structure loc payload =
+ begin match Ast_payload.as_string_exp payload with
+ | Correct exp
+ ->
+ let pexp_desc =
+ Parsetree.Pexp_apply(
+ Exp.ident {txt = Ldot (Ast_literal.Lid.js_unsafe, Literals.raw_stmt); loc},
+ ["",exp]) in
+ Ast_helper.Str.eval
+ { exp with pexp_desc }
-val name_of_ffi : attr -> string
+ | Not_String_Lteral
+ ->
+ Location.raise_errorf ~loc "bs.raw can only be applied to a string"
+ | JS_Regex_Check_Failed
+ ->
+ Location.raise_errorf ~loc "this is an invalid js regex"
+ end
-val check_ffi : ?loc:Location.t -> attr -> unit
-val to_string : t -> string
+let ocaml_obj_as_js_object
+ loc (mapper : Bs_ast_mapper.mapper)
+ (self_pat : Parsetree.pattern)
+ (clfs : Parsetree.class_field list) =
+ let self_type_lit = "self_type" in
-(** Note *)
-val from_string : string -> t
+ (** Attention: we should avoid type variable conflict for each method
+ Since the method name is unique, there would be no conflict
+ OCaml does not allow duplicate instance variable and duplicate methods,
+ but it does allow duplicates between instance variable and method name,
+ we should enforce such rules
+ {[
+ object
+ val x = 3
+ method x = 3
+ end [@bs]
+ ]} should not compile with a meaningful error message
+ *)
+ let generate_val_method_pair
+ loc (mapper : Bs_ast_mapper.mapper)
+ val_name is_mutable =
-end = struct
-#1 "external_ffi_types.ml"
-(* 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 module_bind_name =
- | Phint_name of string
- (* explicit hint name *)
+ let result = Typ.var ~loc val_name in
+ result ,
+ ((val_name , [], result ) ::
+ (if is_mutable then
+ [val_name ^ Literals.setter_suffix,[],
+ to_method_type loc mapper "" result (Ast_literal.type_unit ~loc ()) ]
+ else
+ []) )
+ in
+ (* Note mapper is only for API compatible
+ * TODO: we should check label name to avoid conflict
+ *)
+ let self_type loc = Typ.var ~loc self_type_lit in
- | Phint_nothing
-
+ let generate_arg_type loc (mapper : Bs_ast_mapper.mapper)
+ method_name arity : Ast_core_type.t =
+ let result = Typ.var ~loc method_name in
+ if arity = 0 then
+ to_method_type loc mapper "" (Ast_literal.type_unit ~loc ()) result
-type external_module_name =
- { bundle : string ;
- module_bind_name : module_bind_name
- }
+ else
+ let tyvars =
+ Ext_list.init arity (fun i -> Typ.var ~loc (method_name ^ string_of_int i))
+ in
+ begin match tyvars with
+ | x :: rest ->
+ let method_rest =
+ Ext_list.fold_right (fun v acc -> Typ.arrow ~loc "" v acc)
+ rest result in
+ to_method_type loc mapper "" x method_rest
+ | _ -> assert false
+ end in
-type pipe = bool
-type js_call = {
- name : string;
- external_module_name : external_module_name option;
- splice : bool ;
- scopes : string list ;
-}
+ let generate_method_type
+ loc
+ (mapper : Bs_ast_mapper.mapper)
+ ?alias_type method_name arity =
+ let result = Typ.var ~loc method_name in
-type js_send = {
- name : string ;
- splice : bool ;
- pipe : pipe ;
- js_send_scopes : string list;
-} (* we know it is a js send, but what will happen if you pass an ocaml objct *)
+ let self_type =
+ let v = self_type loc in
+ match alias_type with
+ | None -> v
+ | Some ty -> Typ.alias ~loc ty self_type_lit
+ in
+ if arity = 0 then
+ to_method_callback_type loc mapper "" self_type result
+ else
+ let tyvars =
+ Ext_list.init arity (fun i -> Typ.var ~loc (method_name ^ string_of_int i))
+ in
+ begin match tyvars with
+ | x :: rest ->
+ let method_rest =
+ Ext_list.fold_right (fun v acc -> Typ.arrow ~loc "" v acc)
+ rest result in
+ (to_method_callback_type loc mapper "" self_type
+ (Typ.arrow ~loc "" x method_rest))
+ | _ -> assert false
+ end in
-type js_global_val = {
- name : string ;
- external_module_name : external_module_name option;
- scopes : string list ;
-}
-type js_new_val = {
- name : string ;
- external_module_name : external_module_name option;
- splice : bool ;
- scopes : string list;
-}
+ (** we need calculate the real object type
+ and exposed object type, in some cases there are equivalent
-type js_module_as_fn =
- { external_module_name : external_module_name;
- splice : bool ;
+ for public object type its [@bs.meth] it does not depend on itself
+ while for label argument it is [@bs.this] which depends internal object
+ *)
+ let internal_label_attr_types, public_label_attr_types =
+ Ext_list.fold_right
+ (fun ({pcf_loc = loc} as x : Parsetree.class_field)
+ (label_attr_types, public_label_attr_types) ->
+ match x.pcf_desc with
+ | Pcf_method (
+ label,
+ public_flag,
+ Cfk_concrete
+ (Fresh, e))
+ ->
+ begin match e.pexp_desc with
+ | Pexp_poly
+ (({pexp_desc = Pexp_fun ("", None, pat, e)} ),
+ None) ->
+ let arity = Ast_pat.arity_of_fun pat e in
+ let method_type =
+ generate_arg_type x.pcf_loc mapper label.txt arity in
+ ((label.Asttypes.txt, [], method_type) :: label_attr_types),
+ (if public_flag = Public then
+ (label.Asttypes.txt, [], method_type) :: public_label_attr_types
+ else
+ public_label_attr_types)
- }
-type js_get =
- { js_get_name : string ;
- js_get_scopes : string list;
- }
+ | Pexp_poly( _, Some _)
+ ->
+ Location.raise_errorf ~loc "polymorphic type annotation not supported yet"
+ | Pexp_poly (_, None) ->
+ Location.raise_errorf ~loc
+ "Unsupported syntax, expect syntax like `method x () = x ` "
+ | _ ->
+ Location.raise_errorf ~loc "Unsupported syntax in js object"
+ end
+ | Pcf_val (label, mutable_flag, Cfk_concrete(Fresh, val_exp)) ->
+ let label_type, label_attr =
+ generate_val_method_pair x.pcf_loc mapper label.txt
+ (mutable_flag = Mutable )
+ in
+ (Ext_list.append label_attr label_attr_types, public_label_attr_types)
+ | Pcf_val (label, mutable_flag, Cfk_concrete(Override, val_exp)) ->
+ Location.raise_errorf ~loc "override flag not support currently"
+ | Pcf_val (label, mutable_flag, Cfk_virtual _) ->
+ Location.raise_errorf ~loc "virtual flag not support currently"
-type js_set =
- { js_set_name : string ;
- js_set_scopes : string list
- }
+ | Pcf_method (_, _, Cfk_concrete(Override, _) ) ->
+ Location.raise_errorf ~loc "override flag not supported"
-type js_get_index = {
- js_get_index_scopes : string list
-}
+ | Pcf_method (_, _, Cfk_virtual _ )
+ ->
+ Location.raise_errorf ~loc "virtural method not supported"
-type js_set_index = {
- js_set_index_scopes : string list
-}
-(** TODO: information between [arg_type] and [arg_label] are duplicated,
- design a more compact representation so that it is also easy to seralize by hand
-*)
-type arg_type = External_arg_spec.attr
+ | Pcf_inherit _
+ | Pcf_initializer _
+ | Pcf_attribute _
+ | Pcf_extension _
+ | Pcf_constraint _ ->
+ Location.raise_errorf ~loc "Only method support currently"
+ ) clfs ([], []) in
+ let internal_obj_type = Ast_core_type.make_obj ~loc internal_label_attr_types in
+ let public_obj_type = Ast_core_type.make_obj ~loc public_label_attr_types in
+ let (labels, label_types, exprs, _) =
+ Ext_list.fold_right
+ (fun (x : Parsetree.class_field)
+ (labels,
+ label_types,
+ exprs, aliased ) ->
+ match x.pcf_desc with
+ | Pcf_method (
+ label,
+ _public_flag,
+ Cfk_concrete
+ (Fresh, e))
+ ->
+ begin match e.pexp_desc with
+ | Pexp_poly
+ (({pexp_desc = Pexp_fun ("", None, pat, e)} as f),
+ None) ->
+ let arity = Ast_pat.arity_of_fun pat e in
+ let alias_type =
+ if aliased then None
+ else Some internal_obj_type in
+ let label_type =
+ generate_method_type ?alias_type
+ x.pcf_loc mapper label.txt arity in
+ (label::labels,
+ label_type::label_types,
+ {f with
+ pexp_desc =
+ let f = Ast_pat.is_unit_cont pat ~yes:e ~no:f in
+ to_method_callback loc mapper self_pat f
+ } :: exprs,
+ true
+ )
+ | Pexp_poly( _, Some _)
+ ->
+ Location.raise_errorf ~loc
+ "polymorphic type annotation not supported yet"
-type arg_label = External_arg_spec.label
-
-
-(**TODO: maybe we can merge [arg_label] and [arg_type] *)
-type obj_create = External_arg_spec.t list
-
-type attr =
- | Js_global of js_global_val
- | Js_module_as_var of external_module_name
- | Js_module_as_fn of js_module_as_fn
- | Js_module_as_class of external_module_name
- | Js_call of js_call
- | Js_send of js_send
- | Js_new of js_new_val
- | Js_set of js_set
- | Js_get of js_get
- | Js_get_index of js_get_index
- | Js_set_index of js_set_index
-
-let name_of_ffi ffi =
- match ffi with
- | Js_get_index _scope -> "[@@bs.get_index ..]"
- | Js_set_index _scope -> "[@@bs.set_index ..]"
- | Js_get { js_get_name = s} -> Printf.sprintf "[@@bs.get %S]" s
- | Js_set { js_set_name = s} -> Printf.sprintf "[@@bs.set %S]" s
- | Js_call v -> Printf.sprintf "[@@bs.val %S]" v.name
- | Js_send v -> Printf.sprintf "[@@bs.send %S]" v.name
- | Js_module_as_fn v -> Printf.sprintf "[@@bs.val %S]" v.external_module_name.bundle
- | Js_new v -> Printf.sprintf "[@@bs.new %S]" v.name
- | Js_module_as_class v
- -> Printf.sprintf "[@@bs.module] %S " v.bundle
- | Js_module_as_var v
- ->
- Printf.sprintf "[@@bs.module] %S " v.bundle
- | Js_global v
- ->
- Printf.sprintf "[@@bs.val] %S " v.name
-
-type return_wrapper =
- | Return_unset
- | Return_identity
- | Return_undefined_to_opt
- | Return_null_to_opt
- | Return_null_undefined_to_opt
- | Return_to_ocaml_bool
- | Return_replaced_with_unit
-type t =
- | Ffi_bs of External_arg_spec.t list *
- return_wrapper * attr
- (** [Ffi_bs(args,return,attr) ]
- [return] means return value is unit or not,
- [true] means is [unit]
- *)
- | Ffi_obj_create of obj_create
- | Ffi_normal
- (* When it's normal, it is handled as normal c functional ffi call *)
+ | Pexp_poly (_, None) ->
+ Location.raise_errorf
+ ~loc "Unsupported syntax, expect syntax like `method x () = x ` "
+ | _ ->
+ Location.raise_errorf ~loc "Unsupported syntax in js object"
+ end
+ | Pcf_val (label, mutable_flag, Cfk_concrete(Fresh, val_exp)) ->
+ let label_type, label_attr =
+ generate_val_method_pair x.pcf_loc mapper label.txt
+ (mutable_flag = Mutable )
+ in
+ (label::labels,
+ label_type :: label_types,
+ (mapper.expr mapper val_exp :: exprs),
+ aliased
+ )
+ | Pcf_val (label, mutable_flag, Cfk_concrete(Override, val_exp)) ->
+ Location.raise_errorf ~loc "override flag not support currently"
+ | Pcf_val (label, mutable_flag, Cfk_virtual _) ->
+ Location.raise_errorf ~loc "virtual flag not support currently"
+ | Pcf_method (_, _, Cfk_concrete(Override, _) ) ->
+ Location.raise_errorf ~loc "override flag not supported"
-let valid_js_char =
- let a = Array.init 256 (fun i ->
- let c = Char.chr i in
- (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || (c >= '0' && c <= '9') || c = '_' || c = '$'
- ) in
- (fun c -> Array.unsafe_get a (Char.code c))
+ | Pcf_method (_, _, Cfk_virtual _ )
+ ->
+ Location.raise_errorf ~loc "virtural method not supported"
-let valid_first_js_char =
- let a = Array.init 256 (fun i ->
- let c = Char.chr i in
- (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || c = '_' || c = '$'
- ) in
- (fun c -> Array.unsafe_get a (Char.code c))
-(** Approximation could be improved *)
-let valid_ident (s : string) =
- let len = String.length s in
- len > 0 && valid_js_char s.[0] && valid_first_js_char s.[0] &&
- (let module E = struct exception E end in
- try
- for i = 1 to len - 1 do
- if not (valid_js_char (String.unsafe_get s i)) then
- raise E.E
- done ;
- true
- with E.E -> false )
+ | Pcf_inherit _
+ | Pcf_initializer _
+ | Pcf_attribute _
+ | Pcf_extension _
+ | Pcf_constraint _ ->
+ Location.raise_errorf ~loc "Only method support currently"
+ ) clfs ([], [], [], false) in
+ let pval_type =
+ Ext_list.fold_right2
+ (fun label label_type acc ->
+ Typ.arrow
+ ~loc:label.Asttypes.loc
+ label.Asttypes.txt
+ label_type acc
+ ) labels label_types public_obj_type in
+ Ast_external_mk.local_extern_cont
+ loc
+ ~pval_prim:(External_process.pval_prim_of_labels labels)
+ (fun e ->
+ Exp.apply ~loc e
+ (Ext_list.map2 (fun l expr -> l.Asttypes.txt, expr) labels exprs) )
+ ~pval_type
-let valid_global_name ?loc txt =
- if not (valid_ident txt) then
- let v = Ext_string.split_by ~keep_empty:true (fun x -> x = '.') txt in
- List.iter
- (fun s ->
- if not (valid_ident s) then
- Location.raise_errorf ?loc "Not a valid global name %s" txt
- ) v
-let valid_method_name ?loc txt =
- if not (valid_ident txt) then
- Location.raise_errorf ?loc "Not a valid method name %s" txt
+let record_as_js_object
+ loc
+ (self : Bs_ast_mapper.mapper)
+ (label_exprs : label_exprs)
+ : Parsetree.expression_desc =
+ let labels,args, arity =
+ Ext_list.fold_right (fun ({Location.txt ; loc}, e) (labels,args,i) ->
+ match txt with
+ | Longident.Lident x ->
+ ({Asttypes.loc = loc ; txt = x} :: labels, (x, self.expr self e) :: args, i + 1)
+ | Ldot _ | Lapply _ ->
+ Location.raise_errorf ~loc "invalid js label ") label_exprs ([],[],0) in
+ Ast_external_mk.local_external loc
+ ~pval_prim:(External_process.pval_prim_of_labels labels)
+ ~pval_type:(Ast_core_type.from_labels ~loc arity labels)
+ args
-let check_external_module_name ?loc x =
- match x with
- | {bundle = ""; _ }
- | { module_bind_name = Phint_name "" } ->
- Location.raise_errorf ?loc "empty name encountered"
- | _ -> ()
-let check_external_module_name_opt ?loc x =
- match x with
- | None -> ()
- | Some v -> check_external_module_name ?loc v
+let isCamlExceptionOrOpenVariant = Longident.parse "Caml_exceptions.isCamlExceptionOrOpenVariant"
+let obj_magic = Longident.parse "Obj.magic"
-let check_ffi ?loc ffi =
- match ffi with
- | Js_global {name} -> valid_global_name ?loc name
- | Js_send {name }
- | Js_set {js_set_name = name}
- | Js_get { js_get_name = name}
- -> valid_method_name ?loc name
- | Js_get_index _ (* TODO: check scopes *)
- | Js_set_index _
- -> ()
+let rec checkCases (cases : Parsetree.case list) =
+ List.iter check_case cases
+and check_case case =
+ check_pat case.pc_lhs
+and check_pat (pat : Parsetree.pattern) =
+ match pat.ppat_desc with
+ | Ppat_construct _ -> ()
+ | Ppat_or (l,r) ->
+ check_pat l; check_pat r
+ | _ -> Location.raise_errorf ~loc:pat.ppat_loc "Unsupported pattern in `bs.open`"
- | Js_module_as_var external_module_name
- | Js_module_as_fn {external_module_name; _}
- | Js_module_as_class external_module_name
- -> check_external_module_name external_module_name
- | Js_new {external_module_name ; name}
- | Js_call {external_module_name ; name ; _}
- ->
- check_external_module_name_opt ?loc external_module_name ;
- valid_global_name ?loc name
+let convertBsErrorFunction loc (self : Bs_ast_mapper.mapper) attrs (cases : Parsetree.case list ) =
+ let txt = "match" in
+ let txt_expr = Exp.ident ~loc {txt = Lident txt; loc} in
+ let none = Exp.constraint_ ~loc
+ (Exp.construct ~loc {txt = Lident "None" ; loc} None)
+ (Ast_core_type.lift_option_type (Typ.any ~loc ())) in
+ let () = checkCases cases in
+ let cases = self.cases self cases in
+ Exp.fun_ ~attrs ~loc "" None ( Pat.var ~loc {txt; loc })
+ (Exp.ifthenelse
+ ~loc
+ (Exp.apply ~loc (Exp.ident ~loc {txt = isCamlExceptionOrOpenVariant ; loc}) ["", txt_expr ])
+ (Exp.match_ ~loc
+ (Exp.constraint_ ~loc
+ (Exp.apply ~loc (Exp.ident ~loc {txt = obj_magic; loc}) ["", txt_expr])
+ (Ast_literal.type_exn ~loc ())
+ )
+ (Ext_list.map_append (fun (x :Parsetree.case ) ->
+ let pc_rhs = x.pc_rhs in
+ let loc = pc_rhs.pexp_loc in
+ {
+ x with pc_rhs =
+ Exp.constraint_ ~loc
+ (Exp.construct ~loc {txt = Lident "Some";loc} (Some pc_rhs))
+ (Ast_core_type.lift_option_type (Typ.any ~loc ()) )
+ }
-let bs_prefix = "BS:"
-let bs_prefix_length = String.length bs_prefix
+ ) cases
+ [
+ Exp.case (Pat.any ~loc ()) none
+ ])
+ )
+ (Some none))
+
+
+end
+module Ext_ref : sig
+#1 "ext_ref.mli"
+(* 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. *)
-(** TODO: Make sure each version is not prefix of each other
- Solution:
- 1. fixed length
- 2. non-prefix approach
+(** [non_exn_protect ref value f] assusme [f()]
+ would not raise
*)
-let bs_external = bs_prefix ^ Bs_version.version
-
-let bs_external_length = String.length bs_external
+val non_exn_protect : 'a ref -> 'a -> (unit -> 'b) -> 'b
+val protect : 'a ref -> 'a -> (unit -> 'b) -> 'b
+val protect2 : 'a ref -> 'b ref -> 'a -> 'b -> (unit -> 'c) -> 'c
-let to_string t =
- bs_external ^ Marshal.to_string t []
+(** [non_exn_protect2 refa refb va vb f ]
+ assume [f ()] would not raise
+*)
+val non_exn_protect2 : 'a ref -> 'b ref -> 'a -> 'b -> (unit -> 'c) -> 'c
-
-(* TODO: better error message when version mismatch *)
-let from_string s : t =
- let s_len = String.length s in
- if s_len >= bs_prefix_length &&
- String.unsafe_get s 0 = 'B' &&
- String.unsafe_get s 1 = 'S' &&
- String.unsafe_get s 2 = ':' then
- if Ext_string.starts_with s bs_external then
- Marshal.from_string s bs_external_length
- else
- Ext_pervasives.failwithf
- ~loc:__LOC__
- "Compiler version mismatch. The project might have been built with one version of BuckleScript, and then with another. Please wipe the artifacts and do a clean build."
- else Ffi_normal
-
-end
-module Bs_hash_stubs
-= struct
-#1 "bs_hash_stubs.ml"
-
-
-external hash_string : string -> int = "caml_bs_hash_string" "noalloc";;
-
-external hash_string_int : string -> int -> int = "caml_bs_hash_string_and_int" "noalloc";;
-
-external hash_string_small_int : string -> int -> int = "caml_bs_hash_string_and_small_int" "noalloc";;
-
-external hash_stamp_and_name : int -> string -> int = "caml_bs_hash_stamp_and_name" "noalloc";;
-
-external hash_small_int : int -> int = "caml_bs_hash_small_int" "noalloc";;
-
-external hash_int : int -> int = "caml_bs_hash_int" "noalloc";;
-
-external string_length_based_compare : string -> string -> int = "caml_string_length_based_compare" "noalloc";;
-
-
-external
- int_unsafe_blit :
- int array -> int -> int array -> int -> int -> unit = "caml_int_array_blit" "noalloc";;
-
-
-end
-module String_hash_set : sig
-#1 "string_hash_set.mli"
-(* 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. *)
-
-
-include Hash_set_gen.S with type key = string
+val protect_list : ('a ref * 'a) list -> (unit -> 'b) -> 'b
end = struct
-#1 "string_hash_set.ml"
-# 1 "ext/hash_set.cppo.ml"
+#1 "ext_ref.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -34304,80 +34265,65 @@ end = struct
* 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. *)
-# 31
-type key = string
-let key_index (h : _ Hash_set_gen.t ) (key : key) =
- (Bs_hash_stubs.hash_string key) land (Array.length h.data - 1)
-let eq_key = Ext_string.equal
-type t = key Hash_set_gen.t
-
-
-# 62
-let create = Hash_set_gen.create
-let clear = Hash_set_gen.clear
-let reset = Hash_set_gen.reset
-let copy = Hash_set_gen.copy
-let iter = Hash_set_gen.iter
-let fold = Hash_set_gen.fold
-let length = Hash_set_gen.length
-let stats = Hash_set_gen.stats
-let elements = Hash_set_gen.elements
-
-
-
-let remove (h : _ Hash_set_gen.t) key =
- let i = key_index h key in
- let h_data = h.data in
- let old_h_size = h.size in
- let new_bucket = Hash_set_gen.remove_bucket eq_key key h (Array.unsafe_get h_data i) in
- if old_h_size <> h.size then
- Array.unsafe_set h_data i new_bucket
-
+let non_exn_protect r v body =
+ let old = !r in
+ r := v;
+ let res = body() in
+ r := old;
+ res
-let add (h : _ Hash_set_gen.t) key =
- let i = key_index h key in
- let h_data = h.data in
- let old_bucket = (Array.unsafe_get h_data i) in
- if not (Hash_set_gen.small_bucket_mem eq_key key old_bucket) then
- begin
- Array.unsafe_set h_data i (key :: old_bucket);
- h.size <- h.size + 1 ;
- if h.size > Array.length h_data lsl 1 then Hash_set_gen.resize key_index h
- end
-
-let of_array arr =
- let len = Array.length arr in
- let tbl = create len in
- for i = 0 to len - 1 do
- add tbl (Array.unsafe_get arr i);
- done ;
- tbl
-
-
-let check_add (h : _ Hash_set_gen.t) key =
- let i = key_index h key in
- let h_data = h.data in
- let old_bucket = (Array.unsafe_get h_data i) in
- if not (Hash_set_gen.small_bucket_mem eq_key key old_bucket) then
- begin
- Array.unsafe_set h_data i (key :: old_bucket);
- h.size <- h.size + 1 ;
- if h.size > Array.length h_data lsl 1 then Hash_set_gen.resize key_index h;
- true
- end
- else false
+let protect r v body =
+ let old = !r in
+ try
+ r := v;
+ let res = body() in
+ r := old;
+ res
+ with x ->
+ r := old;
+ raise x
+let non_exn_protect2 r1 r2 v1 v2 body =
+ let old1 = !r1 in
+ let old2 = !r2 in
+ r1 := v1;
+ r2 := v2;
+ let res = body() in
+ r1 := old1;
+ r2 := old2;
+ res
-let mem (h : _ Hash_set_gen.t) key =
- Hash_set_gen.small_bucket_mem eq_key key (Array.unsafe_get h.data (key_index h key))
+let protect2 r1 r2 v1 v2 body =
+ let old1 = !r1 in
+ let old2 = !r2 in
+ try
+ r1 := v1;
+ r2 := v2;
+ let res = body() in
+ r1 := old1;
+ r2 := old2;
+ res
+ with x ->
+ r1 := old1;
+ r2 := old2;
+ raise x
-
+let protect_list rvs body =
+ let olds = Ext_list.map (fun (x,y) -> !x) rvs in
+ let () = List.iter (fun (x,y) -> x:=y) rvs in
+ try
+ let res = body () in
+ List.iter2 (fun (x,_) old -> x := old) rvs olds;
+ res
+ with e ->
+ List.iter2 (fun (x,_) old -> x := old) rvs olds;
+ raise e
end
-module Lam_methname : sig
-#1 "lam_methname.mli"
-(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+module Ast_core_type_class_type : sig
+#1 "ast_core_type_class_type.mli"
+(* Copyright (C) 2018 Authors of BuckleScript
*
* 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
@@ -34403,12 +34349,20 @@ module Lam_methname : sig
-val translate : ?loc:Location.t -> string -> string
+val handle_class_type_fields :
+ Bs_ast_mapper.mapper ->
+ Parsetree.class_type_field list ->
+ Parsetree.class_type_field list
+val handle_core_type :
+ Bs_ast_mapper.mapper ->
+ Parsetree.core_type ->
+ bool ref ->
+ Parsetree.core_type
end = struct
-#1 "lam_methname.ml"
-(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
- *
+#1 "ast_core_type_class_type.ml"
+(* Copyright (C) 2018 Authors of BuckleScript
+ *
* 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
@@ -34426,142 +34380,207 @@ end = struct
* 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. *)
+open Ast_helper
+let process_getter_setter ~no ~get ~set
+ loc name
+ (attrs : Ast_attributes.t)
+ (ty : Parsetree.core_type) acc =
+ match Ast_attributes.process_method_attributes_rev attrs with
+ | {get = None; set = None}, _ -> no ty :: acc
+ | st , pctf_attributes
+ ->
+ let get_acc =
+ match st.set with
+ | Some `No_get -> acc
+ | None
+ | Some `Get ->
+ let lift txt =
+ Typ.constr ~loc {txt ; loc} [ty] in
+ let (null,undefined) =
+ match st with
+ | {get = Some (null, undefined) } -> (null, undefined)
+ | {get = None} -> (false, false ) in
+ let ty =
+ match (null,undefined) with
+ | false, false -> ty
+ | true, false -> lift Ast_literal.Lid.js_null
+ | false, true -> lift Ast_literal.Lid.js_undefined
+ | true , true -> lift Ast_literal.Lid.js_null_undefined in
+ get ty name pctf_attributes
+ :: acc
+ in
+ if st.set = None then get_acc
+ else
+ set ty (name ^ Literals.setter_suffix) pctf_attributes
+ :: get_acc
-(**
- {[
- _open -> open
- _in -> in
- _MAX_LENGTH -> MAX_LENGTH
- _Capital -> Capital
-
- _open__ -> _open
- open__ -> open
-
- _'x -> 'x
+let handle_class_type_field self
+ ({pctf_loc = loc } as ctf : Parsetree.class_type_field)
+ acc =
+ match ctf.pctf_desc with
+ | Pctf_method
+ (name, private_flag, virtual_flag, ty)
+ ->
+ let no (ty : Parsetree.core_type) =
+ let ty =
+ match ty.ptyp_desc with
+ | Ptyp_arrow (label, args, body)
+ ->
+ Ast_util.to_method_type
+ ty.ptyp_loc self label args body
- _Capital__ -> _Capital
- _MAX__ -> _MAX
- __ -> __
- __x -> __x
- ___ -> _
- ____ -> __
- _ -> _ (* error *)
-
+ | Ptyp_poly (strs, {ptyp_desc = Ptyp_arrow (label, args, body);
+ ptyp_loc})
+ ->
+ {ty with ptyp_desc =
+ Ptyp_poly(strs,
+ Ast_util.to_method_type
+ ptyp_loc self label args body )}
+ | _ ->
+ self.typ self ty
+ in
+ {ctf with
+ pctf_desc =
+ Pctf_method (name , private_flag, virtual_flag, ty)}
+ in
+ let get ty name pctf_attributes =
+ {ctf with
+ pctf_desc =
+ Pctf_method (name ,
+ private_flag,
+ virtual_flag,
+ self.typ self ty
+ );
+ pctf_attributes} in
+ let set ty name pctf_attributes =
+ {ctf with
+ pctf_desc =
+ Pctf_method (name,
+ private_flag,
+ virtual_flag,
+ Ast_util.to_method_type
+ loc self "" ty
+ (Ast_literal.type_unit ~loc ())
+ );
+ pctf_attributes} in
+ process_getter_setter ~no ~get ~set loc name ctf.pctf_attributes ty acc
- ]}
- First we scan '__' from end to start,
- If found, discard it.
- Otherwise, check if it is [_ + keyword] or followed by capital letter,
- If so, discard [_].
+ | Pctf_inherit _
+ | Pctf_val _
+ | Pctf_constraint _
+ | Pctf_attribute _
+ | Pctf_extension _ ->
+ Bs_ast_mapper.default_mapper.class_type_field self ctf :: acc
+
- Limitations: user can not have [_Capital__, _Capital__other] to
- make it all compile to [Capital].
- Keyword is fine [open__, open__other].
- So we loose polymorphism over capital letter.
- It is okay, otherwise, if [_Captial__] is interpreted as [Capital], then
- there is no way to express [_Capital]
+(*
+ Attributes are very hard to attribute
+ (since ptyp_attributes could happen in so many places),
+ and write ppx extensions correctly,
+ we can only use it locally
*)
-(* Copied from [ocaml/parsing/lexer.mll] *)
-let key_words = String_hash_set.of_array [|
- "and";
- "as";
- "assert";
- "begin";
- "class";
- "constraint";
- "do";
- "done";
- "downto";
- "else";
- "end";
- "exception";
- "external";
- "false";
- "for";
- "fun";
- "function";
- "functor";
- "if";
- "in";
- "include";
- "inherit";
- "initializer";
- "lazy";
- "let";
- "match";
- "method";
- "module";
- "mutable";
- "new";
- "nonrec";
- "object";
- "of";
- "open";
- "or";
-(* "parser", PARSER; *)
- "private";
- "rec";
- "sig";
- "struct";
- "then";
- "to";
- "true";
- "try";
- "type";
- "val";
- "virtual";
- "when";
- "while";
- "with";
-
- "mod";
- "land";
- "lor";
- "lxor";
- "lsl";
- "lsr";
- "asr";
-|]
-let double_underscore = "__"
-
-(*https://caml.inria.fr/pub/docs/manual-ocaml/lex.html
-{[
-
- label-name ::= lowercase-ident
-]}
-*)
-let valid_start_char x =
- match x with
- | '_' | 'a' .. 'z' -> true
- | _ -> false
-let translate ?loc name =
- assert (not @@ Ext_string.is_empty name);
- let i = Ext_string.rfind ~sub:double_underscore name in
- if i < 0 then
- let name_len = String.length name in
- if name.[0] = '_' then begin
- let try_key_word = (String.sub name 1 (name_len - 1)) in
- if name_len > 1 &&
- (not (valid_start_char try_key_word.[0])
- || String_hash_set.mem key_words try_key_word) then
- try_key_word
- else
- name
+let handle_core_type
+ ~(super : Bs_ast_mapper.mapper)
+ ~(self : Bs_ast_mapper.mapper)
+ (ty : Parsetree.core_type)
+ record_as_js_object
+ =
+ match ty with
+ | {ptyp_desc = Ptyp_extension({txt = ("bs.obj"|"obj")}, PTyp ty)}
+ ->
+ Ext_ref.non_exn_protect record_as_js_object true
+ (fun _ -> self.typ self ty )
+ | {ptyp_attributes ;
+ ptyp_desc = Ptyp_arrow (label, args, body);
+ (* let it go without regard label names,
+ it will report error later when the label is not empty
+ *)
+ ptyp_loc = loc
+ } ->
+ begin match Ast_attributes.process_attributes_rev ptyp_attributes with
+ | `Uncurry , ptyp_attributes ->
+ Ast_util.to_uncurry_type loc self label args body
+ | `Meth_callback, ptyp_attributes ->
+ Ast_util.to_method_callback_type loc self label args body
+ | `Method, ptyp_attributes ->
+ Ast_util.to_method_type loc self label args body
+ | `Nothing , _ ->
+ Bs_ast_mapper.default_mapper.typ self ty
end
- else name
- else if i = 0 then name
- else String.sub name 0 i
-
-
+ | {
+ ptyp_desc = Ptyp_object ( methods, closed_flag) ;
+ ptyp_loc = loc
+ } ->
+ let (+>) attr (typ : Parsetree.core_type) =
+ {typ with ptyp_attributes = attr :: typ.ptyp_attributes} in
+ let new_methods =
+ Ext_list.fold_right (fun (label, ptyp_attrs, core_type) acc ->
+ let get ty name attrs =
+ let attrs, core_type =
+ match Ast_attributes.process_attributes_rev attrs with
+ | `Nothing, attrs -> attrs, ty (* #1678 *)
+ | `Uncurry, attrs ->
+ attrs, Ast_attributes.bs +> ty
+ | `Method, _
+ -> Location.raise_errorf ~loc "bs.get/set conflicts with bs.meth"
+ | `Meth_callback, attrs ->
+ attrs, Ast_attributes.bs_this +> ty
+ in
+ name , attrs, self.typ self core_type in
+ let set ty name attrs =
+ let attrs, core_type =
+ match Ast_attributes.process_attributes_rev attrs with
+ | `Nothing, attrs -> attrs, ty
+ | `Uncurry, attrs ->
+ attrs, Ast_attributes.bs +> ty
+ | `Method, _
+ -> Location.raise_errorf ~loc "bs.get/set conflicts with bs.meth"
+ | `Meth_callback, attrs ->
+ attrs, Ast_attributes.bs_this +> ty
+ in
+ name, attrs, Ast_util.to_method_type loc self "" core_type
+ (Ast_literal.type_unit ~loc ()) in
+ let no ty =
+ let attrs, core_type =
+ match Ast_attributes.process_attributes_rev ptyp_attrs with
+ | `Nothing, attrs -> attrs, ty
+ | `Uncurry, attrs ->
+ attrs, Ast_attributes.bs +> ty
+ | `Method, attrs ->
+ attrs, Ast_attributes.bs_method +> ty
+ | `Meth_callback, attrs ->
+ attrs, Ast_attributes.bs_this +> ty in
+ label, attrs, self.typ self core_type in
+ process_getter_setter ~no ~get ~set
+ loc label ptyp_attrs core_type acc
+ ) methods [] in
+ let inner_type =
+ { ty
+ with ptyp_desc = Ptyp_object(new_methods, closed_flag);
+ } in
+ if !record_as_js_object then
+ Ast_comb.to_js_type loc inner_type
+ else inner_type
+ | _ -> super.typ self ty
+
+let handle_class_type_fields self fields =
+ Ext_list.fold_right
+ (handle_class_type_field self)
+ fields []
+
+let handle_core_type self typ record_as_js_object =
+ handle_core_type
+ ~super:Bs_ast_mapper.default_mapper
+ ~self typ record_as_js_object
end
-module External_process : sig
-#1 "external_process.mli"
+module Ast_signature : sig
+#1 "ast_signature.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -34586,40 +34605,91 @@ module External_process : sig
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
+type item = Parsetree.signature_item
+type t = item list
+val fuseAll : ?loc:Ast_helper.loc -> t -> item
+end = struct
+#1 "ast_signature.ml"
+(* 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 item = Parsetree.signature_item
+type t = item list
-(**
- [handle_attributes_as_string
- loc pval_name.txt pval_type pval_attributes pval_prim]
- [pval_name.txt] is the name of identifier
- [pval_prim] is the name of string literal
-
- return value is of [pval_type, pval_prims, new_attrs]
-*)
-val handle_attributes_as_string :
- Bs_loc.t ->
- string ->
- Ast_core_type.t ->
- Ast_attributes.t ->
- string ->
- Ast_core_type.t * string list * Ast_attributes.t
-
-
+open Ast_helper
+let fuseAll ?(loc=Location.none) (t : t) : item =
+ Sig.include_ ~loc (Incl.mk ~loc (Mty.signature ~loc t))
+
+end
+module Ast_structure : sig
+#1 "ast_structure.mli"
+(* 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. *)
-(** [pval_prim_of_labels labels]
- return [pval_prims] for FFI, it is specialized for
- external object which is used in
- {[ [%obj { x = 2; y = 1} ] ]}
-*)
-val pval_prim_of_labels : string Asttypes.loc list -> string list
+type item = Parsetree.structure_item
+
+type t = item list
+
+
+val fuseAll: ?loc:Ast_helper.loc -> t -> item
+
+(* val fuse_with_constraint:
+ ?loc:Ast_helper.loc ->
+ Parsetree.type_declaration list ->
+ t ->
+ Ast_signature.t ->
+ item *)
+val constraint_ : ?loc:Ast_helper.loc -> t -> Ast_signature.t -> item
end = struct
-#1 "external_process.ml"
+#1 "ast_structure.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -34644,979 +34714,1940 @@ end = struct
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
+type item = Parsetree.structure_item
-[@@@ocaml.warning "+9"]
+type t = item list
+open Ast_helper
-let variant_can_bs_unwrap_fields row_fields =
- let validity =
- List.fold_left
- begin fun st row ->
- match st, row with
- | (* we've seen no fields or only valid fields so far *)
- (`No_fields | `Valid_fields),
- (* and this field has one constructor arg that we can unwrap to *)
- Parsetree.Rtag (label, attrs, false, ([ _ ]))
- ->
- `Valid_fields
- | (* otherwise, this field or a previous field was invalid *)
- _ ->
- `Invalid_field
- end
- `No_fields
- row_fields
- in
- match validity with
- | `Valid_fields -> true
- | `No_fields
- | `Invalid_field -> false
+let fuseAll ?(loc=Location.none) (t : t) : item =
+ Str.include_ ~loc
+ (Incl.mk ~loc (Mod.structure ~loc t ))
+
+(* let fuse_with_constraint
+ ?(loc=Location.none)
+ (item : Parsetree.type_declaration list ) (t : t) (coercion) =
+ Str.include_ ~loc
+ (Incl.mk ~loc
+ (Mod.constraint_
+ (Mod.structure ~loc
+ ({pstr_loc = loc; pstr_desc = Pstr_type item} :: t) )
+ (
+ Mty.signature ~loc
+ ({psig_loc = loc; psig_desc = Psig_type item} :: coercion)
+ )
+ )
+ ) *)
+let constraint_ ?(loc=Location.none) (stru : t) (sign : Ast_signature.t) =
+ Str.include_ ~loc
+ (Incl.mk ~loc
+ (Mod.constraint_ ~loc (Mod.structure ~loc stru) (Mty.signature ~loc sign)))
+end
+module Ast_derive : sig
+#1 "ast_derive.mli"
+(* 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. *)
-(** Given the type of argument, process its [bs.] attribute and new type,
- The new type is currently used to reconstruct the external type
- and result type in [@@bs.obj]
- They are not the same though, for example
- {[
- external f : hi:([ `hi | `lo ] [@bs.string]) -> unit -> _ = "" [@@bs.obj]
- ]}
- The result type would be [ hi:string ]
+type tdcls = Parsetree.type_declaration list
+
+type gen = {
+ structure_gen : tdcls -> bool -> Ast_structure.t ;
+ signature_gen : tdcls -> bool -> Ast_signature.t ;
+ expression_gen : (Parsetree.core_type -> Parsetree.expression) option ;
+}
+
+(**
+ [register name cb]
+ example: [register "accessors" cb]
*)
-let get_arg_type ~nolabel optional
- (ptyp : Ast_core_type.t) :
- External_arg_spec.attr * Ast_core_type.t =
- let ptyp = if optional then Ast_core_type.extract_option_type_exn ptyp else ptyp in
- if Ast_core_type.is_any ptyp then (* (_[@bs.as ])*)
- if optional then
- Bs_syntaxerr.err ptyp.ptyp_loc Invalid_underscore_type_in_external
- else begin
- let ptyp_attrs =
- ptyp.Parsetree.ptyp_attributes
- in
- let result =
- Ast_attributes.iter_process_bs_string_or_int_as ptyp_attrs
- in
- (* when ppx start dropping attributes
- we should warn, there is a trade off whether
- we should warn dropped non bs attribute or not
- *)
- Bs_ast_invariant.warn_unused_attributes ptyp_attrs;
- match result with
- | None ->
- Bs_syntaxerr.err ptyp.ptyp_loc Invalid_underscore_type_in_external
+val register :
+ string ->
+ (Parsetree.expression option -> gen) ->
+ unit
- | Some (`Int i) ->
- Arg_cst(External_arg_spec.cst_int i), Ast_literal.type_int ~loc:ptyp.ptyp_loc ()
- | Some (`Str i)->
- Arg_cst (External_arg_spec.cst_string i), Ast_literal.type_string ~loc:ptyp.ptyp_loc ()
- | Some (`Json_str s) ->
- Arg_cst (External_arg_spec.cst_json ptyp.ptyp_loc s),
- Ast_literal.type_string ~loc:ptyp.ptyp_loc ()
+(* val gen_structure:
+ tdcls ->
+ Ast_payload.action list ->
+ bool ->
+ Ast_structure.t *)
- end
- else (* ([`a|`b] [@bs.string]) *)
- let ptyp_desc = ptyp.ptyp_desc in
- match Ast_attributes.process_bs_string_int_unwrap_uncurry ptyp.ptyp_attributes with
- | (`String, ptyp_attributes)
- ->
- begin match ptyp_desc with
- | Ptyp_variant ( row_fields, Closed, None)
- ->
- let attr =
- Ast_polyvar.map_row_fields_into_strings ptyp.ptyp_loc row_fields in
- attr,
- {ptyp with
- ptyp_attributes
- }
- | _ ->
- Bs_syntaxerr.err ptyp.ptyp_loc Invalid_bs_string_type
- end
- | (`Ignore, ptyp_attributes) ->
- (Ignore, {ptyp with ptyp_attributes})
- | (`Int , ptyp_attributes) ->
- begin match ptyp_desc with
- | Ptyp_variant ( row_fields, Closed, None) ->
- let int_lists =
- Ast_polyvar.map_row_fields_into_ints ptyp.ptyp_loc row_fields in
- Int int_lists ,
- {ptyp with
- ptyp_attributes
- }
- | _ -> Bs_syntaxerr.err ptyp.ptyp_loc Invalid_bs_int_type
- end
- | (`Unwrap, ptyp_attributes) ->
+val gen_signature:
+ tdcls ->
+ Ast_payload.action list ->
+ bool ->
+ Ast_signature.t
- begin match ptyp_desc with
- | (Ptyp_variant (row_fields, Closed, _) as ptyp_desc)
- when variant_can_bs_unwrap_fields row_fields ->
- Unwrap, {ptyp with ptyp_desc; ptyp_attributes}
- | _ ->
- Bs_syntaxerr.err ptyp.ptyp_loc Invalid_bs_unwrap_type
- end
- | (`Uncurry opt_arity, ptyp_attributes) ->
- let real_arity = Ast_core_type.get_uncurry_arity ptyp in
- (begin match opt_arity, real_arity with
- | Some arity, `Not_function ->
- Fn_uncurry_arity arity
- | None, `Not_function ->
- Bs_syntaxerr.err ptyp.ptyp_loc Canot_infer_arity_by_syntax
- | None, `Arity arity ->
- Fn_uncurry_arity arity
- | Some arity, `Arity n ->
- if n <> arity then
- Bs_syntaxerr.err ptyp.ptyp_loc (Inconsistent_arity (arity,n))
- else Fn_uncurry_arity arity
- end, {ptyp with ptyp_attributes})
- | (`Nothing, ptyp_attributes) ->
- begin match ptyp_desc with
- | Ptyp_constr ({txt = Lident "bool"; _}, [])
- ->
- Bs_warnings.prerr_bs_ffi_warning ptyp.ptyp_loc Unsafe_ffi_bool_type;
- Nothing
- | Ptyp_constr ({txt = Lident "unit"; _}, [])
- -> if nolabel then Extern_unit else Nothing
- | Ptyp_constr ({txt = Lident "array"; _}, [_])
- -> Array
- | Ptyp_variant _ ->
- Bs_warnings.prerr_bs_ffi_warning ptyp.ptyp_loc Unsafe_poly_variant_type;
- Nothing
- | _ ->
- Nothing
- end, ptyp
+val gen_expression :
+ string Asttypes.loc ->
+ Parsetree.core_type ->
+ Parsetree.expression
-(**
- [@@bs.module "react"]
- [@@bs.module "react"]
- ---
- [@@bs.module "@" "react"]
- [@@bs.module "@" "react"]
+val gen_structure_signature :
+ Location.t ->
+ Parsetree.type_declaration list ->
+ Ast_payload.action ->
+ bool ->
+ Parsetree.structure_item
+end = struct
+#1 "ast_derive.ml"
+(* 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. *)
- They should have the same module name
+type tdcls = Parsetree.type_declaration list
- TODO: we should emit an warning if we bind
- two external files to the same module name
+type gen = {
+ structure_gen : tdcls -> bool -> Ast_structure.t ;
+ signature_gen : tdcls -> bool -> Ast_signature.t ;
+ expression_gen : (Parsetree.core_type -> Parsetree.expression) option ;
+}
+
+(* the first argument is [config] payload
+ {[
+ { x = {uu} }
+ ]}
*)
-type bundle_source =
- [`Nm_payload of string (* from payload [@@bs.val "xx" ]*)
- |`Nm_external of string (* from "" in external *)
- | `Nm_val of string (* from function name *)
- ]
+type derive_table =
+ (Parsetree.expression option -> gen) String_map.t
-let string_of_bundle_source (x : bundle_source) =
- match x with
- | `Nm_payload x
- | `Nm_external x
- | `Nm_val x -> x
-type name_source =
- [ bundle_source
- | `Nm_na
+let derive_table : derive_table ref = ref String_map.empty
- ]
+let register key value =
+ derive_table := String_map.add key value !derive_table
+(* let gen_structure
+ (tdcls : tdcls)
+ (actions : Ast_payload.action list )
+ (explict_nonrec : bool )
+ : Ast_structure.t =
+ Ext_list.flat_map
+ (fun action ->
+ (Ast_payload.table_dispatch !derive_table action).structure_gen
+ tdcls explict_nonrec) actions *)
-type st =
- { val_name : name_source;
- external_module_name : External_ffi_types.external_module_name option;
- module_as_val : External_ffi_types.external_module_name option;
- val_send : name_source ;
- val_send_pipe : Ast_core_type.t option;
- splice : bool ; (* mutable *)
- scopes : string list ;
- set_index : bool; (* mutable *)
- get_index : bool;
- new_name : name_source ;
- call_name : name_source ;
- set_name : name_source ;
- get_name : name_source ;
+let gen_signature
+ tdcls
+ (actions : Ast_payload.action list )
+ (explict_nonrec : bool )
+ : Ast_signature.t =
+ Ext_list.flat_map
+ (fun action ->
+ (Ast_payload.table_dispatch !derive_table action).signature_gen
+ tdcls explict_nonrec) actions
- mk_obj : bool ;
- return_wrapper : External_ffi_types.return_wrapper ;
+(** used for cases like [%sexp] *)
+let gen_expression ({Asttypes.txt ; loc}) typ =
+ let txt = Ext_string.tail_from txt (String.length Literals.bs_deriving_dot) in
+ match (Ast_payload.table_dispatch !derive_table
+ ({txt ; loc}, None)).expression_gen with
+ | None ->
+ Bs_syntaxerr.err loc (Unregistered txt)
- }
+ | Some f -> f typ
-let init_st =
- {
- val_name = `Nm_na;
- external_module_name = None ;
- module_as_val = None;
- val_send = `Nm_na;
- val_send_pipe = None;
- splice = false;
- scopes = [];
- set_index = false;
- get_index = false;
- new_name = `Nm_na;
- call_name = `Nm_na;
- set_name = `Nm_na ;
- get_name = `Nm_na ;
- mk_obj = false ;
- return_wrapper = Return_unset;
+open Ast_helper
+let gen_structure_signature
+ loc
+ (tdcls : tdcls)
+ (action : Ast_payload.action)
+ (explicit_nonrec : bool) =
+ let derive_table = !derive_table in
+ let u =
+ Ast_payload.table_dispatch derive_table action in
- }
+ let a = u.structure_gen tdcls explicit_nonrec in
+ let b = u.signature_gen tdcls explicit_nonrec in
+ Str.include_ ~loc
+ (Incl.mk ~loc
+ (Mod.constraint_ ~loc
+ (Mod.structure ~loc a)
+ (Mty.signature ~loc b )
+ )
+ )
+end
+module Ast_derive_util : sig
+#1 "ast_derive_util.mli"
+(* Copyright (C) 2017 Authors of BuckleScript
+ *
+ * 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. *)
+
+(** Given a type declaration, extaract the type expression, mostly
+ used in code gen later
+ *)
+ val core_type_of_type_declaration :
+ Parsetree.type_declaration -> Parsetree.core_type
+
+val new_type_of_type_declaration :
+ Parsetree.type_declaration ->
+ string ->
+ Parsetree.core_type * Parsetree.type_declaration
+
+val lift_string_list_to_array : string list -> Parsetree.expression
+val lift_int : int -> Parsetree.expression
+val lift_int_list_to_array : int list -> Parsetree.expression
+val mk_fun :
+ loc:Location.t ->
+ Parsetree.core_type ->
+ string -> Parsetree.expression -> Parsetree.expression
+val destruct_label_declarations :
+ loc:Location.t ->
+ string ->
+ Parsetree.label_declaration list ->
+ (Parsetree.core_type * Parsetree.expression) list * string list
+val notApplicable:
+ Location.t ->
+ string ->
+ unit
+val invalid_config : Parsetree.expression -> 'a
+end = struct
+#1 "ast_derive_util.ml"
+(* 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. *)
+
+open Ast_helper
+
+let core_type_of_type_declaration
+ (tdcl : Parsetree.type_declaration) =
+ match tdcl with
+ | {ptype_name = {txt ; loc};
+ ptype_params ;
+ } ->
+ Typ.constr
+ {txt = Lident txt ; loc}
+ (Ext_list.map fst ptype_params)
+
+let new_type_of_type_declaration
+ (tdcl : Parsetree.type_declaration) newName =
+ match tdcl with
+ | {ptype_name = { loc};
+ ptype_params ;
+ } ->
+ (Typ.constr
+ {txt = Lident newName ; loc}
+ (Ext_list.map fst ptype_params),
+ { Parsetree.ptype_params = tdcl.ptype_params;
+ ptype_name = {txt = newName;loc};
+ ptype_kind = Ptype_abstract;
+ ptype_attributes = [];
+ ptype_loc = tdcl.ptype_loc;
+ ptype_cstrs = []; ptype_private = Public; ptype_manifest = None}
+ )
+
+
+let lift_string_list_to_array (labels : string list) =
+ Exp.array
+ (Ext_list.map (fun s -> Exp.constant (Const_string (s, None)))
+ labels)
+
+let lift_int i = Exp.constant (Const_int i)
+let lift_int_list_to_array (labels : int list) =
+ Exp.array (Ext_list.map lift_int labels)
+
+
+let mk_fun ~loc (typ : Parsetree.core_type)
+ (value : string) body
+ : Parsetree.expression =
+ Exp.fun_
+ "" None
+ (Pat.constraint_ (Pat.var {txt = value ; loc}) typ)
+ body
+
+let destruct_label_declarations ~loc
+ (arg_name : string)
+ (labels : Parsetree.label_declaration list) :
+ (Parsetree.core_type * Parsetree.expression) list * string list
+ =
+ Ext_list.fold_right
+ (fun ({pld_name = {txt}; pld_type} : Parsetree.label_declaration)
+ (core_type_exps, labels) ->
+ ((pld_type,
+ Exp.field (Exp.ident {txt = Lident arg_name ; loc})
+ {txt = Lident txt ; loc}) :: core_type_exps),
+ txt :: labels
+ ) labels ([], [])
+
+let notApplicable
+ loc derivingName =
+ Location.prerr_warning
+ loc
+ (Warnings.Bs_derive_warning ( derivingName ^ " not applicable to this type"))
+
+let invalid_config (config : Parsetree.expression) =
+ Location.raise_errorf ~loc:config.pexp_loc "such configuration is not supported"
+
+end
+module Ast_derive_abstract : sig
+#1 "ast_derive_abstract.mli"
+(* Copyright (C) 2017 Authors of BuckleScript
+ *
+ * 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 handleTdclsInStr :
+ Parsetree.type_declaration list -> Parsetree.structure
+
+val handleTdclsInSig:
+ Parsetree.type_declaration list -> Parsetree.signature
+end = struct
+#1 "ast_derive_abstract.ml"
+(* Copyright (C) 2017 Authors of BuckleScript
+ *
+ * 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 derivingName = "abstract"
+module U = Ast_derive_util
+open Ast_helper
+type tdcls = Parsetree.type_declaration list
+
+let handle_config (config : Parsetree.expression option) =
+ match config with
+ | Some config ->
+ U.invalid_config config
+ | None -> ()
+
+(* see #2337
+ TODO: relax it to allow (int -> int [@bs])
+*)
+let rec checkNotFunciton (ty : Parsetree.core_type) =
+ match ty.ptyp_desc with
+ | Ptyp_poly (_,ty) -> checkNotFunciton ty
+ | Ptyp_alias (ty,_) -> checkNotFunciton ty
+ | Ptyp_arrow _ ->
+ Location.raise_errorf
+ ~loc:ty.ptyp_loc
+ "syntactic function type is not allowed when working with abstract bs.deriving, create a named type as work around"
+ | Ptyp_any
+ | Ptyp_var _
+ | Ptyp_tuple _
+ | Ptyp_constr _
+ | Ptyp_object _
+ | Ptyp_class _
+ | Ptyp_variant _
+ | Ptyp_package _
+ | Ptyp_extension _ -> ()
+let handleTdcl (tdcl : Parsetree.type_declaration) =
+ let core_type = U.core_type_of_type_declaration tdcl in
+ let loc = tdcl.ptype_loc in
+ let name = tdcl.ptype_name.txt in
+ let newTdcl = {
+ tdcl with
+ ptype_kind = Ptype_abstract;
+ ptype_attributes = [];
+ (* avoid non-terminating*)
+ } in
+ match tdcl.ptype_kind with
+ | Ptype_record label_declarations ->
+ let ty =
+ Ext_list.fold_right (fun (label_declaration : Parsetree.label_declaration) acc ->
+ Typ.arrow
+ label_declaration.pld_name.txt label_declaration.pld_type acc
+ ) label_declarations core_type in
+ let setter_accessor =
+ Ext_list.fold_right (fun (x: Parsetree.label_declaration) acc ->
+ let pld_name = x.pld_name.txt in
+ let pld_loc = x.pld_name.loc in
+ let pld_type = x.pld_type in
+ let () = checkNotFunciton pld_type in
+ let setter =
+ Val.mk
+ {loc = pld_loc; txt = pld_name}
+ ~attrs:[Ast_attributes.bs_get]
+ ~prim:[pld_name]
+ (Typ.arrow "" core_type pld_type) :: acc in
+ match x.pld_mutable with
+ | Mutable ->
+ Val.mk
+ {loc = pld_loc; txt = pld_name ^ "Set"}
+ ~attrs:[Ast_attributes.bs_set]
+ ~prim:[pld_name]
+ (Typ.arrow "" core_type (Typ.arrow "" pld_type (Ast_literal.type_unit ()))) :: setter
+ | Immutable -> setter
+ ) label_declarations []
+ in
+
+ newTdcl,
+ (match tdcl.ptype_private with
+ | Private -> setter_accessor
+ | Public ->
+ let maker =
+ Val.mk {loc; txt = name}
+ ~attrs:[Ast_attributes.bs_obj]
+ ~prim:[""] ty in
+ (maker :: setter_accessor))
+
+ | Ptype_abstract
+ | Ptype_variant _
+ | Ptype_open ->
+ (* Looks obvious that it does not make sense to warn *)
+ (* U.notApplicable tdcl.ptype_loc derivingName; *)
+ tdcl, []
+
+let handleTdclsInStr tdcls =
+ let tdcls, code =
+ List.fold_right (fun tdcl (tdcls, sts) ->
+ match handleTdcl tdcl with
+ ntdcl, value_descriptions ->
+ ntdcl::tdcls,
+ Ext_list.map_append (fun x -> Str.primitive x) value_descriptions sts
+
+ ) tdcls ([],[]) in
+ Str.type_ tdcls :: code
+(* still need perform transformation for non-abstract type*)
+
+let handleTdclsInSig tdcls =
+ let tdcls, code =
+ List.fold_right (fun tdcl (tdcls, sts) ->
+ match handleTdcl tdcl with
+ ntdcl, value_descriptions ->
+ ntdcl::tdcls,
+ Ext_list.map_append (fun x -> Sig.value x) value_descriptions sts
+
+ ) tdcls ([],[]) in
+ Sig.type_ tdcls :: code
+end
+module Ast_derive_js_mapper : sig
+#1 "ast_derive_js_mapper.mli"
+(* Copyright (C) 2017 Authors of BuckleScript
+ *
+ * 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 init : unit -> unit
+end = struct
+#1 "ast_derive_js_mapper.ml"
+(* Copyright (C) 2017 Authors of BuckleScript
+ *
+ * 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. *)
+
+open Ast_helper
+module U = Ast_derive_util
+type tdcls = Parsetree.type_declaration list
+
+let js_field (o : Parsetree.expression) m =
+ Exp.apply
+ (Exp.ident {txt = Lident "##"; loc = o.pexp_loc})
+ [
+ "",o;
+ "", Exp.ident m
+ ]
+let const_int i = Exp.constant (Const_int i)
+let const_string s = Exp.constant (Const_string (s,None))
+
+
+let handle_config (config : Parsetree.expression option) =
+ match config with
+ | Some config ->
+ (match config.pexp_desc with
+ | Pexp_record (
+ [
+ {txt = Lident "newType"},
+ {pexp_desc =
+ (Pexp_construct
+ (
+ {txt =
+ Lident ("true"
+ | "false"
+ as x)}, None)
+ | Pexp_ident {txt = Lident ("newType" as x)}
+ )
+ }
+ ],None)
+ -> not (x = "false")
+ | Pexp_ident {txt = Lident ("newType")}
+ -> true
+ | _ -> U.invalid_config config)
+ | None -> false
+let noloc = Location.none
+(* [eraseType] will be instrumented, be careful about the name conflict*)
+let eraseTypeLit = "jsMapperEraseType"
+let eraseTypeExp = Exp.ident {loc = noloc; txt = Lident eraseTypeLit}
+let eraseType x =
+ Exp.apply eraseTypeExp ["", x]
+let eraseTypeStr =
+ let any = Typ.any () in
+ Str.primitive
+ (Val.mk ~prim:["%identity"] {loc = noloc; txt = eraseTypeLit}
+ (Typ.arrow "" any any)
+ )
+
+let app2 f arg1 arg2 =
+ Exp.apply f ["",arg1; "", arg2]
+let app3 f arg1 arg2 arg3 =
+ Exp.apply f ["", arg1; "", arg2; "", arg3]
+let (<=~) a b =
+ app2 (Exp.ident {loc = noloc; txt = Lident "<="}) a b
+let (-~) a b =
+ app2 (Exp.ident {loc = noloc; txt = Ldot(Lident "Pervasives","-")})
+ a b
+let (+~) a b =
+ app2 (Exp.ident {loc = noloc; txt = Ldot(Lident "Pervasives","+")})
+ a b
+let (&&~) a b =
+ app2 (Exp.ident {loc = noloc; txt = Ldot(Lident "Pervasives","&&")})
+ a b
+let (->~) a b = Typ.arrow "" a b
+let jsMapperRt =
+ Longident.Ldot (Lident "Js", "MapperRt")
+
+let search upper polyvar array =
+ app3
+ (Exp.ident ({loc = noloc;
+ txt = Longident.Ldot (jsMapperRt,"binarySearch") })
+ )
+ upper
+ (eraseType polyvar)
+ array
+
+let revSearch len constantArray exp =
+ app3
+ (Exp.ident
+ {loc= noloc;
+ txt = Longident.Ldot (jsMapperRt, "revSearch")})
+ len
+ constantArray
+ exp
+
+let revSearchAssert len constantArray exp =
+ app3
+ (Exp.ident
+ {loc= noloc;
+ txt = Longident.Ldot (jsMapperRt, "revSearchAssert")})
+ len
+ constantArray
+ exp
+
+let toInt exp array =
+ app2
+ (Exp.ident
+ { loc=noloc;
+ txt = Longident.Ldot (jsMapperRt, "toInt")})
+ (eraseType exp)
+ array
+let fromInt len array exp =
+ app3
+ (Exp.ident
+ {loc = noloc;
+ txt = Longident.Ldot (jsMapperRt,"fromInt")})
+ len
+ array
+ exp
+
+let fromIntAssert len array exp =
+ app3
+ (Exp.ident
+ {loc = noloc;
+ txt = Longident.Ldot (jsMapperRt,"fromIntAssert")})
+ len
+ array
+ exp
+
+
+let assertExp e =
+ Exp.extension
+ ({Asttypes.loc = noloc; txt = "assert"},
+ (PStr
+ [Str.eval e ]
+ )
+ )
+let derivingName = "jsConverter"
+
+(* let notApplicable loc =
+ Location.prerr_warning
+ loc
+ (Warnings.Bs_derive_warning ( derivingName ^ " not applicable to this type")) *)
+
+let init () =
+ Ast_derive.register
+ derivingName
+ (fun ( x : Parsetree.expression option) ->
+ let createType = handle_config x in
+
+ {
+ structure_gen = (fun (tdcls : tdcls) _ ->
+ let handle_tdcl (tdcl: Parsetree.type_declaration) =
+ let core_type = U.core_type_of_type_declaration tdcl
+ in
+ let name = tdcl.ptype_name.txt in
+ let toJs = name ^ "ToJs" in
+ let fromJs = name ^ "FromJs" in
+ let constantArray = "jsMapperConstantArray" in
+ let loc = tdcl.ptype_loc in
+ let patToJs = {Asttypes.loc; txt = toJs} in
+ let patFromJs = {Asttypes.loc; txt = fromJs} in
+ let param = "param" in
+
+ let ident_param = {Asttypes.txt = Longident.Lident param; loc} in
+ let pat_param = {Asttypes.loc; txt = param} in
+ let exp_param = Exp.ident ident_param in
+ let newType,newTdcl =
+ U.new_type_of_type_declaration tdcl ("abs_" ^ name) in
+ let newTypeStr = Str.type_ [newTdcl] in
+ let toJsBody body =
+ Ast_comb.single_non_rec_value patToJs
+ (Exp.fun_ "" None (Pat.constraint_ (Pat.var pat_param) core_type)
+ body )
+ in
+ let (+>) a ty =
+ Exp.constraint_ (eraseType a) ty in
+ let (+:) a ty =
+ eraseType (Exp.constraint_ a ty) in
+ let coerceResultToNewType e =
+ if createType then
+ e +> newType
+ else e
+ in
+ match tdcl.ptype_kind with
+ | Ptype_record label_declarations ->
+ let exp =
+ coerceResultToNewType
+ (Exp.extension
+ (
+ {Asttypes.loc; txt = "bs.obj"},
+ (PStr
+ [Str.eval
+ (Exp.record
+ (List.map
+ (fun ({pld_name = {loc; txt } } : Parsetree.label_declaration) ->
+ let label =
+ {Asttypes.loc; txt = Longident.Lident txt } in
+ label,Exp.field exp_param label
+ ) label_declarations) None)]))) in
+ let toJs =
+ toJsBody exp
+ in
+ let obj_exp =
+ Exp.record
+ (List.map
+ (fun ({pld_name = {loc; txt } } : Parsetree.label_declaration) ->
+ let label =
+ {Asttypes.loc; txt = Longident.Lident txt } in
+ label,
+ js_field exp_param label
+ ) label_declarations) None in
+ let fromJs =
+ Ast_comb.single_non_rec_value patFromJs
+ (Exp.fun_ "" None (Pat.var pat_param)
+ (if createType then
+ (Exp.let_ Nonrecursive
+ [Vb.mk
+ (Pat.var pat_param)
+ (exp_param +: newType)]
+ (Exp.constraint_ obj_exp core_type) )
+ else
+ (Exp.constraint_ obj_exp core_type) ))
+ in
+ let rest =
+ [
+ toJs;
+ fromJs
+ ] in
+ if createType then eraseTypeStr:: newTypeStr :: rest else rest
+ | Ptype_abstract ->
+ (match Ast_polyvar.is_enum_polyvar tdcl with
+ | Some row_fields ->
+ let attr =
+ Ast_polyvar.map_row_fields_into_strings loc row_fields
+ in
+ let expConstantArray =
+ Exp.ident {loc; txt = Longident.Lident constantArray} in
+ begin match attr with
+ | NullString result ->
+ let result_len = List.length result in
+ let exp_len = const_int result_len in
+ let v = [
+ eraseTypeStr;
+ Ast_comb.single_non_rec_value
+ {loc; txt = constantArray}
+ (Exp.array
+ (List.map (fun (i,str) ->
+ Exp.tuple
+ [
+ const_int i;
+ const_string str
+ ]
+ ) (List.sort (fun (a,_) (b,_) -> compare (a:int) b) result)));
+ (
+ toJsBody
+ (coerceResultToNewType
+ (search
+ exp_len
+ exp_param
+ expConstantArray
+ ))
+ );
+ Ast_comb.single_non_rec_value
+ patFromJs
+ (Exp.fun_ "" None
+ (Pat.var pat_param)
+ (if createType then
+ revSearchAssert
+ exp_len
+ expConstantArray
+ (exp_param +: newType)
+ +>
+ core_type
+ else
+ revSearch
+ exp_len
+ expConstantArray
+ exp_param
+ +>
+ Ast_core_type.lift_option_type core_type
+ )
+ )
+ ] in
+ if createType then
+ newTypeStr :: v
+ else v
+ | _ -> assert false
+ end
+ | None ->
+ U.notApplicable
+ tdcl.Parsetree.ptype_loc
+ derivingName;
+ []
+ )
+
+ | Ptype_variant ctors ->
+ if Ast_polyvar.is_enum_constructors ctors then
+ let xs = Ast_polyvar.map_constructor_declarations_into_ints ctors in
+ match xs with
+ | `New xs ->
+ let constantArrayExp = Exp.ident {loc; txt = Lident constantArray} in
+ let exp_len = const_int (List.length ctors) in
+ let v = [
+ eraseTypeStr;
+ Ast_comb.single_non_rec_value
+ {loc; txt = constantArray}
+ (Exp.array (List.map (fun i -> const_int i) xs ))
+ ;
+ toJsBody
+ (
+ coerceResultToNewType @@
+ toInt
+ exp_param
+ constantArrayExp
+ )
+ ;
+ Ast_comb.single_non_rec_value
+ patFromJs
+ (Exp.fun_ "" None
+ (Pat.var pat_param)
+ (
+ if createType then
+ fromIntAssert
+ exp_len
+ constantArrayExp
+ (exp_param +: newType)
+ +>
+ core_type
+ else
+ fromInt
+ exp_len
+ constantArrayExp
+ exp_param
+ +>
+ Ast_core_type.lift_option_type core_type
+
+ )
+ )
+ ] in
+ if createType then newTypeStr :: v else v
+ | `Offset offset ->
+ let v =
+ [ eraseTypeStr;
+ toJsBody (
+ coerceResultToNewType
+ (eraseType exp_param +~ const_int offset)
+ )
+ ;
+ let len = List.length ctors in
+ let range_low = const_int (offset + 0) in
+ let range_upper = const_int (offset + len - 1) in
+
+ Ast_comb.single_non_rec_value
+ {loc ; txt = fromJs}
+ (Exp.fun_ "" None
+ (Pat.var pat_param)
+ (if createType then
+ (Exp.let_ Nonrecursive
+ [Vb.mk
+ (Pat.var pat_param)
+ (exp_param +: newType)
+ ]
+ (
+ Exp.sequence
+ (assertExp
+ ((exp_param <=~ range_upper) &&~ (range_low <=~ exp_param))
+ )
+ (exp_param -~ const_int offset))
+ )
+ +>
+ core_type
+ else
+ (Exp.ifthenelse
+ ( (exp_param <=~ range_upper) &&~ (range_low <=~ exp_param))
+ (Exp.construct {loc; txt = Lident "Some"}
+ ( Some (exp_param -~ const_int offset)))
+ (Some (Exp.construct {loc; txt = Lident "None"} None)))
+ +>
+ Ast_core_type.lift_option_type core_type
+ )
+ )
+ ] in
+ if createType then newTypeStr :: v else v
+ else
+ begin
+ U.notApplicable
+ tdcl.Parsetree.ptype_loc
+ derivingName;
+ []
+ end
+ | Ptype_open ->
+ U.notApplicable tdcl.Parsetree.ptype_loc
+ derivingName;
+ [] in
+ Ext_list.flat_map handle_tdcl tdcls
+ );
+ signature_gen =
+ (fun (tdcls : tdcls) _ ->
+ let handle_tdcl tdcl =
+ let core_type = U.core_type_of_type_declaration tdcl
+ in
+ let name = tdcl.ptype_name.txt in
+ let toJs = name ^ "ToJs" in
+ let fromJs = name ^ "FromJs" in
+ let loc = tdcl.ptype_loc in
+ let patToJs = {Asttypes.loc; txt = toJs} in
+ let patFromJs = {Asttypes.loc; txt = fromJs} in
+ let toJsType result =
+ Ast_comb.single_non_rec_val patToJs (Typ.arrow "" core_type result) in
+ let newType,newTdcl =
+ U.new_type_of_type_declaration tdcl ("abs_" ^ name) in
+ let newTypeStr = Sig.type_ [newTdcl] in
+ let (+?) v rest = if createType then v :: rest else rest in
+ match tdcl.ptype_kind with
+ | Ptype_record label_declarations ->
+ let objType flag =
+ Ast_comb.to_js_type loc @@
+ Typ.object_
+ (List.map
+ (fun ({pld_name = {loc; txt }; pld_type } : Parsetree.label_declaration) ->
+ txt, [], pld_type
+ ) label_declarations)
+ flag in
+ newTypeStr +?
+ [
+ toJsType (if createType then newType else objType Closed);
+ Ast_comb.single_non_rec_val patFromJs
+ ( (if createType then newType else objType Open)->~ core_type)
+ ]
+ | Ptype_abstract ->
+ (match Ast_polyvar.is_enum_polyvar tdcl with
+ | Some _ ->
+ let ty1 =
+ if createType then newType else
+ (Ast_literal.type_string ()) in
+ let ty2 =
+ if createType then core_type
+ else Ast_core_type.lift_option_type core_type in
+ newTypeStr +?
+ [
+ toJsType ty1;
+ Ast_comb.single_non_rec_val
+ patFromJs
+ (ty1 ->~ ty2)
+ ]
-let process_external_attributes
- no_arguments
- (prim_name_or_pval_prim: [< bundle_source ] as 'a)
- pval_prim
- (prim_attributes : Ast_attributes.t) : _ * Ast_attributes.t =
+ | None ->
+ U.notApplicable tdcl.Parsetree.ptype_loc
+ derivingName;
+ [])
- (* shared by `[@@bs.val]`, `[@@bs.send]`,
- `[@@bs.set]`, `[@@bs.get]` , `[@@bs.new]`
- `[@@bs.send.pipe]` does not use it
- *)
- let name_from_payload_or_prim ~loc (payload : Parsetree.payload) : name_source =
- match payload with
- | PStr [] ->
- (prim_name_or_pval_prim :> name_source)
- (* It is okay to have [@@bs.val] without payload *)
- | _ ->
- begin match Ast_payload.is_single_string payload with
- | Some (val_name, _) -> `Nm_payload val_name
- | None ->
- Location.raise_errorf ~loc "Invalid payload"
- end
+ | Ptype_variant ctors
+ ->
- in
- List.fold_left
- (fun (st, attrs)
- (({txt ; loc}, payload) as attr : Ast_attributes.attr)
- ->
- if Ext_string.starts_with txt "bs." then
- begin match txt with
- | "bs.val" ->
- if no_arguments then
- {st with val_name = name_from_payload_or_prim ~loc payload}
- else
- {st with call_name = name_from_payload_or_prim ~loc payload}
+ if Ast_polyvar.is_enum_constructors ctors then
+ let ty1 =
+ if createType then newType
+ else Ast_literal.type_int() in
+ let ty2 =
+ if createType then core_type
+ else Ast_core_type.lift_option_type core_type in
+ newTypeStr +?
+ [
+ toJsType ty1;
+ Ast_comb.single_non_rec_val
+ patFromJs
+ (ty1 ->~ ty2)
+ ]
- | "bs.module" ->
- begin match Ast_payload.assert_strings loc payload with
- | [bundle] ->
- {st with external_module_name =
- Some {bundle; module_bind_name = Phint_nothing}}
- | [bundle;bind_name] ->
- {st with external_module_name =
- Some {bundle; module_bind_name = Phint_name bind_name}}
- | [] ->
- { st with
- module_as_val =
- Some
- { bundle =
- string_of_bundle_source
- (prim_name_or_pval_prim :> bundle_source) ;
- module_bind_name = Phint_nothing}
- }
- | _ ->
- Bs_syntaxerr.err loc Illegal_attribute
- end
- | "bs.scope" ->
- begin match Ast_payload.assert_strings loc payload with
- | [] ->
- Bs_syntaxerr.err loc Illegal_attribute
- (* We need err on empty scope, so we can tell the difference
- between unset/set
- *)
- | scopes -> { st with scopes = scopes }
- end
- | "bs.splice" -> {st with splice = true}
- | "bs.send" ->
- { st with val_send = name_from_payload_or_prim ~loc payload}
- | "bs.send.pipe"
- ->
- { st with val_send_pipe = Some (Ast_payload.as_core_type loc payload)}
- | "bs.set" ->
- {st with set_name = name_from_payload_or_prim ~loc payload}
- | "bs.get" -> {st with get_name = name_from_payload_or_prim ~loc payload}
+ else
+ begin
+ U.notApplicable tdcl.Parsetree.ptype_loc
+ derivingName;
+ []
+ end
+ | Ptype_open ->
+ U.notApplicable tdcl.Parsetree.ptype_loc
+ derivingName;
+ [] in
+ Ext_list.flat_map handle_tdcl tdcls
- | "bs.new" -> {st with new_name = name_from_payload_or_prim ~loc payload}
- | "bs.set_index" -> {st with set_index = true}
- | "bs.get_index"-> {st with get_index = true}
- | "bs.obj" -> {st with mk_obj = true}
- | "bs.return" ->
- let aux loc txt : External_ffi_types.return_wrapper =
- begin match txt with
- | "undefined_to_opt" -> Return_undefined_to_opt
- | "null_to_opt" -> Return_null_to_opt
- | "nullable"
- | "null_undefined_to_opt" -> Return_null_undefined_to_opt
- | "identity" -> Return_identity
- | _ ->
- Bs_syntaxerr.err loc Not_supported_directive_in_bs_return
- end in
- let actions =
- Ast_payload.ident_or_record_as_config loc payload
- in
- begin match actions with
- | [ ({txt; _ },None) ] ->
- { st with return_wrapper = aux loc txt}
- | _ ->
- Bs_syntaxerr.err loc Not_supported_directive_in_bs_return
- end
- | _ -> (Location.prerr_warning loc (Bs_unused_attribute txt); st)
- end, attrs
- else (st , attr :: attrs)
+ );
+ expression_gen = None
+ }
)
- (init_st, []) prim_attributes
-
-
-let rec has_bs_uncurry (attrs : Ast_attributes.t) =
- match attrs with
- | ({txt = "bs.uncurry"; _ }, _) :: attrs ->
- true
- | _ :: attrs -> has_bs_uncurry attrs
- | [] -> false
-
+;
-let check_return_wrapper
- loc (wrapper : External_ffi_types.return_wrapper)
- result_type =
- match wrapper with
- | Return_identity -> wrapper
- | Return_unset ->
- if Ast_core_type.is_unit result_type then
- Return_replaced_with_unit
- else if Ast_core_type.is_user_bool result_type then
- Return_to_ocaml_bool
- else
- wrapper
- | Return_undefined_to_opt
- | Return_null_to_opt
- | Return_null_undefined_to_opt
- ->
- if Ast_core_type.is_user_option result_type then
- wrapper
- else
- Bs_syntaxerr.err loc Expect_opt_in_bs_return_to_opt
- | Return_replaced_with_unit
- | Return_to_ocaml_bool ->
- assert false (* Not going to happen from user input*)
+end
+module Ast_derive_projector : sig
+#1 "ast_derive_projector.mli"
+(* Copyright (C) 2017 Authors of BuckleScript
+ *
+ * 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 init : unit -> unit
-(** Note that the passed [type_annotation] is already processed by visitor pattern before
-*)
-let handle_attributes
- (loc : Bs_loc.t)
- (pval_prim : string )
- (type_annotation : Parsetree.core_type)
- (prim_attributes : Ast_attributes.t) (prim_name : string)
- : Ast_core_type.t * string * External_ffi_types.t * Ast_attributes.t =
- (** sanity check here
- {[ int -> int -> (int -> int -> int [@bs.uncurry])]}
- It does not make sense
- *)
- if has_bs_uncurry type_annotation.Parsetree.ptyp_attributes then
- begin
- Location.raise_errorf
- ~loc "[@@bs.uncurry] can not be applied to the whole definition"
- end;
+end = struct
+#1 "ast_derive_projector.ml"
+open Ast_helper
- let prim_name_or_pval_prim =
- if String.length prim_name = 0 then `Nm_val pval_prim
- else `Nm_external prim_name (* need check name *)
- in
- let result_type, arg_types_ty =
- Ast_core_type.list_of_arrow type_annotation in
- if has_bs_uncurry result_type.ptyp_attributes then
- begin
- Location.raise_errorf
- ~loc:result_type.ptyp_loc
- "[@@bs.uncurry] can not be applied to tailed position"
- end ;
- let (st, left_attrs) =
- process_external_attributes
- (arg_types_ty = [])
- prim_name_or_pval_prim pval_prim prim_attributes in
+let invalid_config (config : Parsetree.expression) =
+ Location.raise_errorf ~loc:config.pexp_loc "such configuration is not supported"
- if st.mk_obj then
- begin match st with
- | {
- val_name = `Nm_na;
- external_module_name = None ;
- module_as_val = None;
- val_send = `Nm_na;
- val_send_pipe = None;
- splice = false;
- new_name = `Nm_na;
- call_name = `Nm_na;
- set_name = `Nm_na ;
- get_name = `Nm_na ;
- get_index = false ;
- return_wrapper = Return_unset ;
- set_index = false ;
- mk_obj = _;
- scopes = [];
- (* wrapper does not work with [bs.obj]
- TODO: better error message *)
- } ->
- if String.length prim_name <> 0 then
- Location.raise_errorf ~loc "[@@bs.obj] expect external names to be empty string";
- let arg_kinds, new_arg_types_ty, result_types =
- Ext_list.fold_right
- (fun (label,ty,attr,loc) ( arg_labels, arg_types, result_types) ->
- let arg_label = Ast_core_type.label_name label in
- let new_arg_label, new_arg_types, output_tys =
- match arg_label with
- | Empty ->
- let arg_type, new_ty = get_arg_type ~nolabel:true false ty in
- begin match arg_type with
- | Extern_unit ->
- External_arg_spec.empty_kind arg_type, (label,new_ty,attr,loc)::arg_types, result_types
- | _ ->
- Location.raise_errorf ~loc "expect label, optional, or unit here"
- end
- | Label name ->
- let arg_type, new_ty = get_arg_type ~nolabel:false false ty in
- begin match arg_type with
- | Ignore ->
- External_arg_spec.empty_kind arg_type,
- (label,new_ty,attr,loc)::arg_types, result_types
- | Arg_cst i ->
- let s = (Lam_methname.translate ~loc name) in
- {arg_label = External_arg_spec.label s (Some i);
- arg_type },
- arg_types, (* ignored in [arg_types], reserved in [result_types] *)
- ((name , [], new_ty) :: result_types)
- | Nothing | Array ->
- let s = (Lam_methname.translate ~loc name) in
- {arg_label = External_arg_spec.label s None ; arg_type },
- (label,new_ty,attr,loc)::arg_types,
- ((name , [], new_ty) :: result_types)
- | Int _ ->
- let s = Lam_methname.translate ~loc name in
- {arg_label = External_arg_spec.label s None; arg_type},
- (label,new_ty,attr,loc)::arg_types,
- ((name, [], Ast_literal.type_int ~loc ()) :: result_types)
- | NullString _ ->
- let s = Lam_methname.translate ~loc name in
- {arg_label = External_arg_spec.label s None; arg_type},
- (label,new_ty,attr,loc)::arg_types,
- ((name, [], Ast_literal.type_string ~loc ()) :: result_types)
- | Fn_uncurry_arity _ ->
- Location.raise_errorf ~loc
- "The combination of [@@bs.obj], [@@bs.uncurry] is not supported yet"
- | Extern_unit -> assert false
- | NonNullString _
- ->
- Location.raise_errorf ~loc
- "bs.obj label %s does not support such arg type" name
- | Unwrap ->
- Location.raise_errorf ~loc
- "bs.obj label %s does not support [@bs.unwrap] arguments" name
- end
- | Optional name ->
- let arg_type, new_ty_extract = get_arg_type ~nolabel:false true ty in
- let new_ty = Ast_core_type.lift_option_type new_ty_extract in
- begin match arg_type with
- | Ignore ->
- External_arg_spec.empty_kind arg_type,
- (label,new_ty,attr,loc)::arg_types, result_types
- | Nothing | Array ->
- let s = (Lam_methname.translate ~loc name) in
- {arg_label = External_arg_spec.optional s; arg_type},
- (label,new_ty,attr,loc)::arg_types,
- ( (name, [], Ast_comb.to_undefined_type loc new_ty_extract) :: result_types)
- | Int _ ->
- let s = Lam_methname.translate ~loc name in
- {arg_label = External_arg_spec.optional s ; arg_type },
- (label,new_ty,attr,loc)::arg_types,
- ((name, [], Ast_comb.to_undefined_type loc @@ Ast_literal.type_int ~loc ()) :: result_types)
- | NullString _ ->
- let s = Lam_methname.translate ~loc name in
- {arg_label = External_arg_spec.optional s ; arg_type },
- (label,new_ty,attr,loc)::arg_types,
- ((name, [], Ast_comb.to_undefined_type loc @@ Ast_literal.type_string ~loc ()) :: result_types)
- | Arg_cst _
- ->
- Location.raise_errorf ~loc "bs.as is not supported with optional yet"
- | Fn_uncurry_arity _ ->
- Location.raise_errorf ~loc
- "The combination of [@@bs.obj], [@@bs.uncurry] is not supported yet"
- | Extern_unit -> assert false
- | NonNullString _
- ->
- Location.raise_errorf ~loc
- "bs.obj label %s does not support such arg type" name
- | Unwrap ->
- Location.raise_errorf ~loc
- "bs.obj label %s does not support [@bs.unwrap] arguments" name
- end
- in
- (
- new_arg_label::arg_labels,
- new_arg_types,
- output_tys)) arg_types_ty
- ( [], [], []) in
+type tdcls = Parsetree.type_declaration list
+
+let derivingName = "accessors"
+let init () =
+
+ Ast_derive.register
+ derivingName
+ (fun (x : Parsetree.expression option) ->
+ (match x with
+ | Some config -> invalid_config config
+ | None -> ());
+ {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
+ ->
+ label_declarations
+ |> Ext_list.map (
+ 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
+ (Exp.fun_ "" None
+ (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
+ ->
+ constructor_declarations
+ |> Ext_list.map
+ (fun
+ ( {pcd_name = {loc ; txt = con_name} ; pcd_args ; pcd_loc }:
+ Parsetree.constructor_declaration)
+ -> (* TODO: add type annotations *)
+ let little_con_name = String.uncapitalize con_name in
+ let arity = List.length pcd_args 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)
+ core_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 = Longident.Lident (List.hd vars )}
+ else
+ Exp.tuple (Ext_list.map
+ (fun x -> Exp.ident {loc ; txt = Longident.Lident x})
+ vars
+ ) )) core_type
+ in
+ Ext_list.fold_right (fun var b ->
+ Exp.fun_ "" None (Pat.var {loc ; txt = var}) b
+ ) vars exp
+
+ 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 handle_tdcl tdcls
+
+
+ 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
+ ->
+ label_declarations
+ |> Ext_list.map
+ (fun
+ ({pld_name ;
+ pld_type
+ } :
+ Parsetree.label_declaration) ->
+ Ast_comb.single_non_rec_val pld_name (Typ.arrow "" core_type pld_type )
+ )
+ | Ptype_variant constructor_declarations
+ ->
+ constructor_declarations
+ |>
+ Ext_list.map
+ (fun ({pcd_name = {loc ; txt = con_name} ; pcd_args ; pcd_loc }:
+ Parsetree.constructor_declaration)
+ ->
+ Ast_comb.single_non_rec_val {loc ; txt = (String.uncapitalize con_name)}
+ (Ext_list.fold_right
+ (fun x acc -> Typ.arrow "" x acc)
+ pcd_args
+ core_type))
+ | Ptype_open | Ptype_abstract ->
+ Ast_derive_util.notApplicable tdcl.ptype_loc derivingName ;
+ []
+ in
+ Ext_list.flat_map handle_tdcl tdcls
+ end;
+ expression_gen = None
+ }
+ )
- let result =
- if Ast_core_type.is_any result_type then
- Ast_core_type.make_obj ~loc result_types
- else
- snd @@ get_arg_type ~nolabel:true false result_type (* result type can not be labeled *)
- in
- begin
- (
- Ext_list.fold_right (fun (label,ty,attrs,loc) acc ->
- Ast_helper.Typ.arrow ~loc ~attrs label ty acc
- ) new_arg_types_ty result
- ) ,
- prim_name,
- Ffi_obj_create arg_kinds,
- left_attrs
- end
+end
+module Ast_exp_apply : sig
+#1 "ast_exp_apply.mli"
+(* Copyright (C) 2018 Authors of BuckleScript
+ *
+ * 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. *)
- | _ -> Location.raise_errorf ~loc "Attribute found that conflicts with [@@bs.obj]"
- end
+val handle_exp_apply :
+ Parsetree.expression ->
+ Bs_ast_mapper.mapper ->
+ Parsetree.expression ->
+ (Asttypes.label * Parsetree.expression) list ->
+ Parsetree.expression
- else
- let splice = st.splice in
- let arg_type_specs, new_arg_types_ty, arg_type_specs_length =
- Ext_list.fold_right
- (fun (label,ty,attr,loc) (arg_type_specs, arg_types, i) ->
- let arg_label = Ast_core_type.label_name label in
- let arg_label, arg_type, new_arg_types =
- match arg_label with
- | Optional s ->
+end = struct
+#1 "ast_exp_apply.ml"
+(* Copyright (C) 2018 Authors of BuckleScript
+ *
+ * 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 arg_type , new_ty = get_arg_type ~nolabel:false true ty in
- begin match arg_type with
- | NonNullString _ ->
- (* ?x:([`x of int ] [@bs.string]) does not make sense *)
- Location.raise_errorf
- ~loc
- "[@@bs.string] does not work with optional when it has arities in label %s" label
- | _ ->
- External_arg_spec.optional s, arg_type,
- ((label, Ast_core_type.lift_option_type new_ty , attr,loc) :: arg_types) end
- | Label s ->
- begin match get_arg_type ~nolabel:false false ty with
- | (Arg_cst ( i) as arg_type), new_ty ->
- External_arg_spec.label s (Some i), arg_type, arg_types
- | arg_type, new_ty ->
- External_arg_spec.label s None, arg_type, (label, new_ty,attr,loc) :: arg_types
- end
- | Empty ->
- begin match get_arg_type ~nolabel:true false ty with
- | (Arg_cst ( i) as arg_type), new_ty ->
- External_arg_spec.empty_lit i , arg_type, arg_types
- | arg_type, new_ty ->
- External_arg_spec.empty_label, arg_type, (label, new_ty,attr,loc) :: arg_types
- end
- in
- (if i = 0 && splice then
- match arg_type with
- | Array -> ()
- | _ -> Location.raise_errorf ~loc "[@@@@bs.splice] expect the last type to be an array");
- ({ External_arg_spec.arg_label ;
- arg_type
- } :: arg_type_specs,
- new_arg_types,
- if arg_type = Ignore then i
- else i + 1
+open Ast_helper
+
+let handle_exp_apply
+ (e : Parsetree.expression)
+ (self : Bs_ast_mapper.mapper)
+ (fn : Parsetree.expression)
+ (args : (Asttypes.label * Parsetree.expression) list)
+ =
+ let loc = e.pexp_loc in
+ begin match fn with
+ | {pexp_desc =
+ Pexp_apply (
+ {pexp_desc =
+ Pexp_ident {txt = Lident "##" ; loc} ; _},
+ [("", obj) ;
+ ("", {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _} )
+ ]);
+ _} -> (* f##paint 1 2 *)
+ {e with pexp_desc = Ast_util.method_apply loc self obj name args }
+ | {pexp_desc =
+ Pexp_apply (
+ {pexp_desc =
+ Pexp_ident {txt = Lident "#@" ; loc} ; _},
+ [("", obj) ;
+ ("", {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _} )
+ ]);
+ _} -> (* f##paint 1 2 *)
+ {e with pexp_desc = Ast_util.property_apply loc self obj name args }
+
+ | {pexp_desc =
+ Pexp_ident {txt = Lident "##" ; loc} ; _}
+ ->
+ begin match args with
+ | [("", obj) ;
+ ("", {pexp_desc = Pexp_apply(
+ {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _},
+ args
+ ); pexp_attributes = attrs }
+ (* we should warn when we discard attributes *)
)
- ) arg_types_ty
- (match st with
- | {val_send_pipe = Some obj; _ } ->
- let arg_type, new_ty = get_arg_type ~nolabel:true false obj in
- begin match arg_type with
- | Arg_cst _ ->
- Location.raise_errorf ~loc:obj.ptyp_loc "[@bs.as] is not supported in bs.send type "
- | _ ->
- (* more error checking *)
- [External_arg_spec.empty_kind arg_type]
- ,
- ["", new_ty, [], obj.ptyp_loc]
- ,0
- end
+ ] -> (* f##(paint 1 2 ) *)
+ (* gpr#1063 foo##(bar##baz) we should rewrite (bar##baz)
+ first before pattern match.
+ currently the pattern match is written in a top down style.
+ Another corner case: f##(g a b [@bs])
+ *)
+ Bs_ast_invariant.warn_unused_attributes attrs ;
+ {e with pexp_desc = Ast_util.method_apply loc self obj name args}
+ | [("", obj) ;
+ ("",
+ {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _}
+ ) (* f##paint *)
+ ] ->
+ { e with pexp_desc =
+ Ast_util.js_property loc (self.expr self obj) name
+ }
- | {val_send_pipe = None ; _ } -> [],[], 0) in
+ | _ ->
+ Location.raise_errorf ~loc
+ "Js object ## expect syntax like obj##(paint (a,b)) "
+ end
+ (* we can not use [:=] for precedece cases
+ like {[i @@ x##length := 3 ]}
+ is parsed as {[ (i @@ x##length) := 3]}
+ since we allow user to create Js objects in OCaml, it can be of
+ ref type
+ {[
+ let u = object (self)
+ val x = ref 3
+ method setX x = self##x := 32
+ method getX () = !self##x
+ end
+ ]}
+ *)
+ | {pexp_desc =
+ Pexp_ident {txt = Lident ("#=" )}
+ } ->
+ begin match args with
+ | ["",
+ {pexp_desc =
+ Pexp_apply ({pexp_desc = Pexp_ident {txt = Lident "##"}},
+ ["", obj;
+ "", {pexp_desc = Pexp_ident {txt = Lident name}}
+ ]
+ )};
+ "", arg
+ ] ->
+ Exp.constraint_ ~loc
+ { e with
+ pexp_desc =
+ Ast_util.method_apply loc self obj
+ (name ^ Literals.setter_suffix) ["", arg ] }
+ (Ast_literal.type_unit ~loc ())
+ | _ -> Bs_ast_mapper.default_mapper.expr self e
+ end
+ | _ ->
+ begin match
+ Ext_list.exclude_with_val
+ Ast_attributes.is_bs e.pexp_attributes with
+ | false, _ -> Bs_ast_mapper.default_mapper.expr self e
+ | true, pexp_attributes ->
+ {e with pexp_desc = Ast_util.uncurry_fn_apply loc self fn args ;
+ pexp_attributes }
+ end
+ end
- let ffi : External_ffi_types.attr = match st with
- | {set_index = true;
+end
+module Ast_exp_extension : sig
+#1 "ast_exp_extension.mli"
+(* Copyright (C) 2018 Authors of BuckleScript
+ *
+ * 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_name = `Nm_na;
- external_module_name = None ;
- module_as_val = None;
- val_send = `Nm_na;
- val_send_pipe = None;
- splice = false;
- scopes ;
- get_index = false;
- new_name = `Nm_na;
- call_name = `Nm_na;
- set_name = `Nm_na ;
- get_name = `Nm_na ;
- return_wrapper = _;
- mk_obj = _ ;
+val handle_extension :
+ bool ref ->
+ Parsetree.expression ->
+ Bs_ast_mapper.mapper ->
+ Parsetree.extension ->
+ Parsetree.expression
+
+end = struct
+#1 "ast_exp_extension.ml"
+(* Copyright (C) 2018 Authors of BuckleScript
+ *
+ * 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. *)
+open Ast_helper
+
+let handle_extension record_as_js_object e (self : Bs_ast_mapper.mapper)
+ (({txt ; loc} as lid , payload) : Parsetree.extension) =
+ begin match txt with
+ | "bs.raw" | "raw" ->
+ Ast_util.handle_raw loc payload
+ | "bs.re" | "re" ->
+ Exp.constraint_ ~loc
+ (Ast_util.handle_raw ~check_js_regex:true loc payload)
+ (Ast_comb.to_js_re_type loc)
+ | "bs.external" | "external" ->
+ begin match Ast_payload.as_ident payload with
+ | Some {txt = Lident x}
+ -> Ast_util.handle_external loc x
+ (* do we need support [%external gg.xx ]
+
+ {[ Js.Undefined.to_opt (if Js.typeof x == "undefined" then x else Js.Undefined.empty ) ]}
+ *)
+
+ | None | Some _ ->
+ Location.raise_errorf ~loc
+ "external expects a single identifier"
+ end
+ | "bs.time"| "time" ->
+ (
+ match payload with
+ | PStr [{pstr_desc = Pstr_eval (e,_)}] ->
+ let locString =
+ if loc.loc_ghost then
+ "GHOST LOC"
+ else
+ let loc_start = loc.loc_start in
+ let (file, lnum, __) = Location.get_pos_info loc_start in
+ Printf.sprintf "%s %d"
+ file lnum in
+ let e = self.expr self e in
+ Exp.sequence ~loc
+ (Exp.apply ~loc
+ (Exp.ident ~loc {loc;
+ txt =
+ Ldot (Ldot (Lident "Js", "Console"), "timeStart")
+ })
+ ["", Exp.constant ~loc (Const_string (locString,None))]
+ )
+ ( Exp.let_ ~loc Nonrecursive
+ [Vb.mk ~loc (Pat.var ~loc {loc; txt = "timed"}) e ;
+ ]
+ (Exp.sequence ~loc
+ (Exp.apply ~loc
+ (Exp.ident ~loc {loc;
+ txt =
+ Ldot (Ldot (Lident "Js", "Console"), "timeEnd")
+ })
+ ["", Exp.constant ~loc (Const_string (locString,None))]
+ )
+ (Exp.ident ~loc {loc; txt = Lident "timed"})
+ )
+ )
+ | _ ->
+ Location.raise_errorf
+ ~loc "expect a boolean expression in the payload"
+ )
+ | "bs.assert" | "assert" ->
+ (
+ match payload with
+ | PStr [ {pstr_desc = Pstr_eval( e,_)}] ->
+
+ let locString =
+ if loc.loc_ghost then
+ "ASSERT FAILURE"
+ else
+ let loc_start = loc.loc_start in
+ let (file, lnum, cnum) = Location.get_pos_info loc_start in
+ let enum =
+ loc.Location.loc_end.Lexing.pos_cnum -
+ loc_start.Lexing.pos_cnum + cnum in
+ Printf.sprintf "File %S, line %d, characters %d-%d"
+ file lnum cnum enum in
+ let raiseWithString locString =
+ (Exp.apply ~loc
+ (Exp.ident ~loc {loc; txt =
+ Ldot(Ldot (Lident "Js","Exn"),"raiseError")})
+ ["",
+
+ Exp.constant (Const_string (locString,None))
+ ])
+ in
+ (match e.pexp_desc with
+ | Pexp_construct({txt = Lident "false"},None) ->
+ (* The backend will convert [assert false] into a nop later *)
+ if !Clflags.no_assert_false then
+ Exp.assert_ ~loc
+ (Exp.construct ~loc {txt = Lident "false";loc} None)
+ else
+ (raiseWithString locString)
+ | Pexp_constant (Const_string (r, _)) ->
+ if !Clflags.noassert then
+ Exp.assert_ ~loc (Exp.construct ~loc {txt = Lident "true"; loc} None)
+ (* Need special handling to make it type check*)
+ else
+ raiseWithString r
+ | _ ->
+ let e = self.expr self e in
+ if !Clflags.noassert then
+ (* pass down so that it still type check, but the backend will
+ make it a nop
+ *)
+ Exp.assert_ ~loc e
+ else
+ Exp.ifthenelse ~loc
+ (Exp.apply ~loc
+ (Exp.ident {loc ; txt = Ldot(Lident "Pervasives","not")})
+ ["", e]
+ )
+ (raiseWithString locString)
+ None
+ )
+ | _ ->
+ Location.raise_errorf
+ ~loc "expect a boolean expression in the payload"
+ )
+ | "bs.node" | "node" ->
+ let strip s =
+ match s with
+ | "_module" -> "module"
+ | x -> x in
+ begin match Ast_payload.as_ident payload with
+ | Some {txt = Lident
+ ( "__filename"
+ | "__dirname"
+ | "_module"
+ | "require" as name); loc}
+ ->
+ let exp =
+ Ast_util.handle_external loc (strip name) in
+ let typ =
+ Ast_core_type.lift_option_type
+ @@
+ if name = "_module" then
+ Typ.constr ~loc
+ { txt = Ldot (Lident "Node", "node_module") ;
+ loc} []
+ else if name = "require" then
+ (Typ.constr ~loc
+ { txt = Ldot (Lident "Node", "node_require") ;
+ loc} [] )
+ else
+ Ast_literal.type_string ~loc () in
+ Exp.constraint_ ~loc exp typ
+ | Some _ | None ->
+ begin match payload with
+ | PTyp _ ->
+ Location.raise_errorf
+ ~loc "Illegal payload, expect an expression payload instead of type payload"
+ | PPat _ ->
+ Location.raise_errorf
+ ~loc "Illegal payload, expect an expression payload instead of pattern payload"
+ | _ ->
+ Location.raise_errorf
+ ~loc "Illegal payload"
+ end
+
+ end
+ | "bs.debugger"|"debugger" ->
+ {e with pexp_desc = Ast_util.handle_debugger loc payload}
+ | "bs.obj" | "obj" ->
+ begin match payload with
+ | PStr [{pstr_desc = Pstr_eval (e,_)}]
+ ->
+ Ext_ref.non_exn_protect record_as_js_object true
+ (fun () -> self.expr self e )
+ | _ -> Location.raise_errorf ~loc "Expect an expression here"
+ end
+ | _ ->
+ match payload with
+ | PTyp typ when Ext_string.starts_with txt Literals.bs_deriving_dot ->
+ self.expr self (Ast_derive.gen_expression lid typ)
+ | _ ->
+ e (* For an unknown extension, we don't really need to process further*)
+ (* Exp.extension ~loc ~attrs:e.pexp_attributes (
+ self.extension self extension) *)
+ (* Bs_ast_mapper.default_mapper.expr self e *)
+ end
- }
- ->
- if String.length prim_name <> 0 then
- Location.raise_errorf ~loc "[@@bs.set_index] expect external names to be empty string";
- if arg_type_specs_length = 3 then
- Js_set_index {js_set_index_scopes = scopes}
- else
- Location.raise_errorf ~loc "Ill defined attribute [@@bs.set_index](arity of 3)"
+end
+module Ast_tuple_pattern_flatten : sig
+#1 "ast_tuple_pattern_flatten.mli"
+(* Copyright (C) 2018 Authors of BuckleScript
+ *
+ * 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. *)
- | {set_index = true; _}
- ->
- Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.set_index]")
- | {get_index = true;
+val handle_value_bindings :
+ Bs_ast_mapper.mapper ->
+ Parsetree.value_binding list ->
+ Parsetree.value_binding list
+end = struct
+#1 "ast_tuple_pattern_flatten.ml"
+(* Copyright (C) 2018 Authors of BuckleScript
+ *
+ * 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_name = `Nm_na;
- external_module_name = None ;
- module_as_val = None;
- val_send = `Nm_na;
- val_send_pipe = None;
+ type loc = Location.t
- splice = false;
- scopes ;
- new_name = `Nm_na;
- call_name = `Nm_na;
- set_name = `Nm_na ;
- get_name = `Nm_na ;
- set_index = false;
- mk_obj;
- return_wrapper ;
- } ->
- if String.length prim_name <> 0 then
- Location.raise_errorf ~loc "[@@bs.get_index] expect external names to be empty string";
- if arg_type_specs_length = 2 then
- Js_get_index {js_get_index_scopes = scopes}
- else Location.raise_errorf ~loc
- "Ill defined attribute [@@bs.get_index] (arity expected 2 : while %d)" arg_type_specs_length
+ type acc =
+ (Asttypes.override_flag * Longident.t Asttypes.loc * loc *
+ Parsetree.attributes) list
- | {get_index = true; _}
+let rec is_simple_pattern (p : Parsetree.pattern) =
+ match p.ppat_desc with
+ | Ppat_any -> true
+ | Ppat_var _ -> true
+ | Ppat_constraint(p,_) -> is_simple_pattern p
+ | _ -> false
+
+(**
+ destruct such pattern
+ {[ A.B.let open C in (a,b)]}
+*)
+let rec destruct_open
+ (e : Parsetree.expression) (acc : acc)
+ : (acc * Parsetree.expression list) option =
+ match e.pexp_desc with
+ | Pexp_open (flag, lid, cont)
+ ->
+ destruct_open
+ cont
+ ((flag, lid, e.pexp_loc, e.pexp_attributes) :: acc)
+ | Pexp_tuple es -> Some (acc, es)
+ | _ -> None
- ->
- Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.get_index]")
+(*
+ [let (a,b) = M.N.(c,d) ]
+ =>
+ [ let a = M.N.c
+ and b = M.N.d ]
+*)
+let flattern_tuple_pattern_vb
+ (self : Bs_ast_mapper.mapper)
+ ({pvb_loc } as vb : Parsetree.value_binding)
+ acc : Parsetree.value_binding list =
+ let pvb_pat = self.pat self vb.pvb_pat in
+ let pvb_expr = self.expr self vb.pvb_expr in
+ let pvb_attributes = self.attributes self vb.pvb_attributes in
+ match destruct_open pvb_expr [] , pvb_pat.ppat_desc with
+ | Some (wholes, es), Ppat_tuple xs
+ when
+ List.for_all is_simple_pattern xs &&
+ Ext_list.same_length es xs
+ ->
+ (Ext_list.fold_right2 (fun pat exp acc->
+ {Parsetree.
+ pvb_pat =
+ pat;
+ pvb_expr =
+ ( match wholes with
+ | [] -> exp
+ | _ ->
+ List.fold_left (fun x (flag,lid,loc,attrs) ->
+ {Parsetree.
+ pexp_desc = Pexp_open(flag,lid,x);
+ pexp_attributes = attrs;
+ pexp_loc = loc
+ }
+ ) exp wholes) ;
+ pvb_attributes;
+ pvb_loc ;
+ } :: acc
+ ) xs es) acc
+ | _ ->
+ {pvb_pat ;
+ pvb_expr ;
+ pvb_loc ;
+ pvb_attributes} :: acc
- | {module_as_val = Some external_module_name ;
+let handle_value_bindings =
+ fun self (vbs : Parsetree.value_binding list) ->
+ (* Bs_ast_mapper.default_mapper.value_bindings self vbs *)
+ List.fold_right (fun vb acc ->
+ flattern_tuple_pattern_vb self vb acc
+ ) vbs []
+end
+module Ext_char : sig
+#1 "ext_char.mli"
+(* 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. *)
- get_index = false;
- val_name ;
- new_name ;
- external_module_name = None ;
- val_send = `Nm_na;
- val_send_pipe = None;
- scopes = []; (* module as var does not need scopes *)
- splice;
- call_name = `Nm_na;
- set_name = `Nm_na ;
- get_name = `Nm_na ;
- set_index = false;
- return_wrapper = _;
- mk_obj = _ ;
- } ->
- begin match arg_types_ty, new_name, val_name with
- | [], `Nm_na, _ -> Js_module_as_var external_module_name
- | _, `Nm_na, _ -> Js_module_as_fn {splice; external_module_name }
- | _, #bundle_source, #bundle_source ->
- Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.module].")
- | _, (`Nm_val _ | `Nm_external _) , `Nm_na
- -> Js_module_as_class external_module_name
- | _, `Nm_payload _ , `Nm_na
- ->
- Location.raise_errorf ~loc
- "Incorrect FFI attribute found: (bs.new should not carry a payload here)"
- end
- | {module_as_val = Some x; _}
- ->
- Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.module].")
- | {call_name = (`Nm_val name | `Nm_external name | `Nm_payload name) ;
- splice;
- scopes ;
- external_module_name;
- val_name = `Nm_na ;
- module_as_val = None;
- val_send = `Nm_na ;
- val_send_pipe = None;
- set_index = false;
- get_index = false;
- new_name = `Nm_na;
- set_name = `Nm_na ;
- get_name = `Nm_na ;
- mk_obj = _ ;
- return_wrapper = _ ;
- } ->
- Js_call {splice; name; external_module_name; scopes }
- | {call_name = #bundle_source ; _ }
- ->
- Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.val]")
+(** Extension to Standard char module, avoid locale sensitivity *)
+val escaped : char -> string
- | {val_name = (`Nm_val name | `Nm_external name | `Nm_payload name);
- external_module_name;
- call_name = `Nm_na ;
- module_as_val = None;
- val_send = `Nm_na ;
- val_send_pipe = None;
- set_index = false;
- get_index = false;
- new_name = `Nm_na;
- set_name = `Nm_na ;
- get_name = `Nm_na;
- mk_obj = _;
- return_wrapper = _;
- splice = false ;
- scopes ;
- }
- ->
- Js_global { name; external_module_name; scopes}
- | {val_name = #bundle_source ; _ }
- ->
- Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.val]")
+val valid_hex : char -> bool
- | {splice ;
- scopes ;
- external_module_name = (Some _ as external_module_name);
+val is_lower_case : char -> bool
+end = struct
+#1 "ext_char.ml"
+(* 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_name = `Nm_na ;
- call_name = `Nm_na ;
- module_as_val = None;
- val_send = `Nm_na ;
- val_send_pipe = None;
- set_index = false;
- get_index = false;
- new_name = `Nm_na;
- set_name = `Nm_na ;
- get_name = `Nm_na ;
- mk_obj = _ ;
- return_wrapper= _ ;
- }
- ->
- let name = string_of_bundle_source prim_name_or_pval_prim in
- if arg_type_specs_length = 0 then
- Js_global { name; external_module_name; scopes}
- else Js_call {splice; name; external_module_name; scopes}
- | {val_send = (`Nm_val name | `Nm_external name | `Nm_payload name);
- splice;
- scopes;
- val_send_pipe = None;
- val_name = `Nm_na ;
- call_name = `Nm_na ;
- module_as_val = None;
- set_index = false;
- get_index = false;
- new_name = `Nm_na;
- set_name = `Nm_na ;
- get_name = `Nm_na ;
- external_module_name = None ;
- mk_obj = _ ;
- return_wrapper = _ ;
- } ->
- (* PR #2162 - since when we assemble arguments the first argument in
- [@@bs.send] is ignored
- *)
- begin match arg_type_specs with
- | [] ->
- Location.raise_errorf
- ~loc "Ill defined attribute [@@bs.send] (at least one argument)"
- | {arg_type = Arg_cst _ ; arg_label = _} :: _
- ->
- Location.raise_errorf
- ~loc "Ill defined attribute [@@bs.send] (first argument can not be const)"
- | _ :: _ ->
- Js_send {splice ; name; js_send_scopes = scopes ; pipe = false}
- end
- | {val_send = #bundle_source; _ }
- -> Location.raise_errorf ~loc "You used an FFI attribute that can't be used with [@@bs.send]"
- | {val_send_pipe = Some typ;
- (* splice = (false as splice); *)
- val_send = `Nm_na;
- val_name = `Nm_na ;
- call_name = `Nm_na ;
- module_as_val = None;
- set_index = false;
- get_index = false;
- new_name = `Nm_na;
- set_name = `Nm_na ;
- get_name = `Nm_na ;
- external_module_name = None ;
- mk_obj = _;
- return_wrapper = _;
- scopes;
- splice ;
- } ->
- (** can be one argument *)
- Js_send {splice ;
- name = string_of_bundle_source prim_name_or_pval_prim;
- js_send_scopes = scopes;
- pipe = true}
- | {val_send_pipe = Some _ ; _}
- -> Location.raise_errorf ~loc "conflict attributes found with [@@bs.send.pipe]"
- | {new_name = (`Nm_val name | `Nm_external name | `Nm_payload name);
- external_module_name;
- val_name = `Nm_na ;
- call_name = `Nm_na ;
- module_as_val = None;
- set_index = false;
- get_index = false;
- val_send = `Nm_na ;
- val_send_pipe = None;
- set_name = `Nm_na ;
- get_name = `Nm_na ;
- splice ;
- scopes;
- mk_obj = _ ;
- return_wrapper = _ ;
+external string_unsafe_set : string -> int -> char -> unit
+ = "%string_unsafe_set"
- }
- -> Js_new {name; external_module_name; splice; scopes}
- | {new_name = #bundle_source ; _ }
- ->
- Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.new]")
+external string_create: int -> string = "caml_create_string"
+external unsafe_chr: int -> char = "%identity"
- | {set_name = (`Nm_val name | `Nm_external name | `Nm_payload name);
+(** {!Char.escaped} is locale sensitive in 4.02.3, fixed in the trunk,
+ backport it here
+ *)
+let escaped = function
+ | '\'' -> "\\'"
+ | '\\' -> "\\\\"
+ | '\n' -> "\\n"
+ | '\t' -> "\\t"
+ | '\r' -> "\\r"
+ | '\b' -> "\\b"
+ | ' ' .. '~' as c ->
+ let s = string_create 1 in
+ string_unsafe_set s 0 c;
+ s
+ | c ->
+ let n = Char.code c in
+ let s = string_create 4 in
+ string_unsafe_set s 0 '\\';
+ string_unsafe_set s 1 (unsafe_chr (48 + n / 100));
+ string_unsafe_set s 2 (unsafe_chr (48 + (n / 10) mod 10));
+ string_unsafe_set s 3 (unsafe_chr (48 + n mod 10));
+ s
- val_name = `Nm_na ;
- call_name = `Nm_na ;
- module_as_val = None;
- set_index = false;
- get_index = false;
- val_send = `Nm_na ;
- val_send_pipe = None;
- new_name = `Nm_na ;
- get_name = `Nm_na ;
- external_module_name = None;
- splice = false;
- mk_obj = _ ;
- return_wrapper = _;
- scopes ;
- }
- ->
- if arg_type_specs_length = 2 then
- Js_set { js_set_scopes = scopes ; js_set_name = name}
- else Location.raise_errorf ~loc "Ill defined attribute [@@bs.set] (two args required)"
- | {set_name = #bundle_source; _}
- -> Location.raise_errorf ~loc "conflict attributes found with [@@bs.set]"
+let valid_hex x =
+ match x with
+ | '0' .. '9'
+ | 'a' .. 'f'
+ | 'A' .. 'F' -> true
+ | _ -> false
- | {get_name = (`Nm_val name | `Nm_external name | `Nm_payload name);
- val_name = `Nm_na ;
- call_name = `Nm_na ;
- module_as_val = None;
- set_index = false;
- get_index = false;
- val_send = `Nm_na ;
- val_send_pipe = None;
- new_name = `Nm_na ;
- set_name = `Nm_na ;
- external_module_name = None;
- splice = false ;
- mk_obj = _;
- return_wrapper = _;
- scopes
- }
- ->
- if arg_type_specs_length = 1 then
- Js_get { js_get_name = name; js_get_scopes = scopes }
- else
- Location.raise_errorf ~loc "Ill defined attribute [@@bs.get] (only one argument)"
- | {get_name = #bundle_source; _}
- -> Location.raise_errorf ~loc "Attribute found that conflicts with [@@bs.get]"
- | {get_name = `Nm_na;
- val_name = `Nm_na ;
- call_name = `Nm_na ;
- module_as_val = None;
- set_index = false;
- get_index = false;
- val_send = `Nm_na ;
- val_send_pipe = None;
- new_name = `Nm_na ;
- set_name = `Nm_na ;
- external_module_name = None;
- splice = _ ;
- scopes = _;
- mk_obj = _;
- return_wrapper = _;
+let is_lower_case c =
+ (c >= 'a' && c <= 'z')
+ || (c >= '\224' && c <= '\246')
+ || (c >= '\248' && c <= '\254')
+end
+module Ast_utf8_string : sig
+#1 "ast_utf8_string.mli"
+(* 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. *)
- }
- -> Location.raise_errorf ~loc "Could not infer which FFI category it belongs to, maybe you forgot [%@%@bs.val]? " in
- begin
- External_ffi_types.check_ffi ~loc ffi;
- (* result type can not be labeled *)
- (* currently we don't process attributes of
- return type, in the future we may *)
- let new_result_type = result_type in
- (* get_arg_type ~nolabel:true false result_type in *)
- let return_wrapper : External_ffi_types.return_wrapper =
- check_return_wrapper loc st.return_wrapper new_result_type
- in
- (
- Ext_list.fold_right (fun (label,ty,attrs,loc) acc ->
- Ast_helper.Typ.arrow ~loc ~attrs label ty acc
- ) new_arg_types_ty new_result_type
- ) ,
- prim_name,
- (Ffi_bs (arg_type_specs,return_wrapper , ffi)), left_attrs
- end
+type error
-let handle_attributes_as_string
- pval_loc
- pval_prim
- (typ : Ast_core_type.t) attrs v =
- let pval_type, prim_name, ffi, processed_attrs =
- handle_attributes pval_loc pval_prim typ attrs v in
- pval_type, [prim_name; External_ffi_types.to_string ffi], processed_attrs
+type exn += Error of int (* offset *) * error
+val pp_error : Format.formatter -> error -> unit
-let pval_prim_of_labels labels =
- let encoding =
- let arg_kinds =
- Ext_list.fold_right
- (fun {Asttypes.loc ; txt } arg_kinds
- ->
- let arg_label = External_arg_spec.label (Lam_methname.translate ~loc txt) None in
- {External_arg_spec.arg_type = Nothing ;
- arg_label } :: arg_kinds
- )
- labels [] in
- External_ffi_types.to_string
- (Ffi_obj_create arg_kinds) in
- [""; encoding]
+
+(* module Interp : sig *)
+(* val check_and_transform : int -> string -> int -> cxt -> unit *)
+(* val transform_test : string -> segments *)
+(* end *)
+val transform_test : string -> string
-end
-module Ast_util : sig
-#1 "ast_util.mli"
+val transform : Location.t -> string -> string
+
+
+end = struct
+#1 "ast_utf8_string.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -35642,116 +36673,183 @@ module Ast_util : sig
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-type args = (string * Parsetree.expression) list
-type loc = Location.t
-type label_exprs = (Longident.t Asttypes.loc * Parsetree.expression) list
-type 'a cxt = loc -> Bs_ast_mapper.mapper -> 'a
-
-(** In general three kinds of ast generation.
- - convert a curried to type to uncurried
- - convert a curried fun to uncurried fun
- - convert a uncuried application to normal
-*)
-type uncurry_expression_gen =
- (Parsetree.pattern ->
- Parsetree.expression ->
- Parsetree.expression_desc) cxt
-type uncurry_type_gen =
- (string -> (* label for error checking *)
- Parsetree.core_type ->
- Parsetree.core_type ->
- Parsetree.core_type) cxt
-(** TODO: the interface is not reusable, it depends on too much context *)
-(** syntax: {[f arg0 arg1 [@bs]]}*)
-val uncurry_fn_apply :
- (Parsetree.expression ->
- args ->
- Parsetree.expression_desc ) cxt
+type error =
+ | Invalid_code_point
+ | Unterminated_backslash
+ | Invalid_escape_code of char
+ | Invalid_hex_escape
+ | Invalid_unicode_escape
-(** syntax : {[f## arg0 arg1 ]}*)
-val method_apply :
- (Parsetree.expression ->
- string ->
- args ->
- Parsetree.expression_desc) cxt
+let pp_error fmt err =
+ Format.pp_print_string fmt @@ match err with
+ | Invalid_code_point -> "Invalid code point"
+ | Unterminated_backslash -> "\\ ended unexpectedly"
+ | Invalid_escape_code c -> "Invalid escape code: " ^ String.make 1 c
+ | Invalid_hex_escape ->
+ "Invalid \\x escape"
+ | Invalid_unicode_escape -> "Invalid \\u escape"
-(** syntax {[f#@ arg0 arg1 ]}*)
-val property_apply :
- (Parsetree.expression ->
- string ->
- args ->
- Parsetree.expression_desc) cxt
-(**
- [function] can only take one argument, that is the reason we did not adopt it
- syntax:
- {[ fun [@bs] pat pat1-> body ]}
- [to_uncurry_fn (fun pat -> (fun pat1 -> ... body))]
+type exn += Error of int (* offset *) * error
-*)
-val to_uncurry_fn : uncurry_expression_gen
-(** syntax:
- {[fun [@bs.this] obj pat pat1 -> body]}
-*)
-val to_method_callback : uncurry_expression_gen
+let error ~loc error =
+ raise (Error (loc, error))
-(** syntax :
- {[ int -> int -> int [@bs]]}
+(** Note the [loc] really should be the utf8-offset, it has nothing to do with our
+ escaping mechanism
*)
-val to_uncurry_type : uncurry_type_gen
-
+(* we can not just print new line in ES5
+ seems we don't need
+ escape "\b" "\f"
+ we need escape "\n" "\r" since
+ ocaml multiple-line allows [\n]
+ visual input while es5 string
+ does not*)
-(** syntax
- {[ method : int -> itn -> int ]}
-*)
-val to_method_type : uncurry_type_gen
+let rec check_and_transform (loc : int ) buf s byte_offset s_len =
+ if byte_offset = s_len then ()
+ else
+ let current_char = s.[byte_offset] in
+ match Ext_utf8.classify current_char with
+ | Single 92 (* '\\' *) ->
+ escape_code (loc + 1) buf s (byte_offset+1) s_len
+ | Single 34 ->
+ Buffer.add_string buf "\\\"";
+ check_and_transform (loc + 1) buf s (byte_offset + 1) s_len
+ | Single 39 ->
+ Buffer.add_string buf "\\'";
+ check_and_transform (loc + 1) buf s (byte_offset + 1) s_len
+ | Single 10 ->
+ Buffer.add_string buf "\\n";
+ check_and_transform (loc + 1) buf s (byte_offset + 1) s_len
+ | Single 13 ->
+ Buffer.add_string buf "\\r";
+ check_and_transform (loc + 1) buf s (byte_offset + 1) s_len
+ | Single _ ->
+ Buffer.add_char buf current_char;
+ check_and_transform (loc + 1) buf s (byte_offset + 1) s_len
-(** syntax:
- {[ 'obj -> int -> int [@bs.this] ]}
-*)
-val to_method_callback_type : uncurry_type_gen
+ | Invalid
+ | Cont _ -> error ~loc Invalid_code_point
+ | Leading (n,_) ->
+ let i' = Ext_utf8.next s ~remaining:n byte_offset in
+ if i' < 0 then
+ error ~loc Invalid_code_point
+ else
+ begin
+ for k = byte_offset to i' do
+ Buffer.add_char buf s.[k];
+ done;
+ check_and_transform (loc + 1 ) buf s (i' + 1) s_len
+ end
+(* we share the same escape sequence with js *)
+and escape_code loc buf s offset s_len =
+ if offset >= s_len then
+ error ~loc Unterminated_backslash
+ else
+ Buffer.add_char buf '\\';
+ let cur_char = s.[offset] in
+ match cur_char with
+ | '\\'
+ | 'b'
+ | 't'
+ | 'n'
+ | 'v'
+ | 'f'
+ | 'r'
+ | '0'
+ | '$'
+ ->
+ begin
+ Buffer.add_char buf cur_char ;
+ check_and_transform (loc + 1) buf s (offset + 1) s_len
+ end
+ | 'u' ->
+ begin
+ Buffer.add_char buf cur_char;
+ unicode (loc + 1) buf s (offset + 1) s_len
+ end
+ | 'x' -> begin
+ Buffer.add_char buf cur_char ;
+ two_hex (loc + 1) buf s (offset + 1) s_len
+ end
+ | _ -> error ~loc (Invalid_escape_code cur_char)
+and two_hex loc buf s offset s_len =
+ if offset + 1 >= s_len then
+ error ~loc Invalid_hex_escape;
+ (*Location.raise_errorf ~loc "\\x need at least two chars";*)
+ let a, b = s.[offset], s.[offset + 1] in
+ if Ext_char.valid_hex a && Ext_char.valid_hex b then
+ begin
+ Buffer.add_char buf a ;
+ Buffer.add_char buf b ;
+ check_and_transform (loc + 2) buf s (offset + 2) s_len
+ end
+ else
+ error ~loc Invalid_hex_escape
+(*Location.raise_errorf ~loc "%c%c is not a valid hex code" a b*)
+
+and unicode loc buf s offset s_len =
+ if offset + 3 >= s_len then
+ error ~loc Invalid_unicode_escape
+ (*Location.raise_errorf ~loc "\\u need at least four chars"*)
+ ;
+ let a0,a1,a2,a3 = s.[offset], s.[offset+1], s.[offset+2], s.[offset+3] in
+ if
+ Ext_char.valid_hex a0 &&
+ Ext_char.valid_hex a1 &&
+ Ext_char.valid_hex a2 &&
+ Ext_char.valid_hex a3 then
+ begin
+ Buffer.add_char buf a0;
+ Buffer.add_char buf a1;
+ Buffer.add_char buf a2;
+ Buffer.add_char buf a3;
+ check_and_transform (loc + 4) buf s (offset + 4) s_len
+ end
+ else
+ error ~loc Invalid_unicode_escape
+(*Location.raise_errorf ~loc "%c%c%c%c is not a valid unicode point"
+ a0 a1 a2 a3 *)
+(* http://www.2ality.com/2015/01/es6-strings.html
+ console.log('\uD83D\uDE80'); (* ES6*)
+ console.log('\u{1F680}');
+*)
-val record_as_js_object :
- (label_exprs ->
- Parsetree.expression_desc) cxt
-val js_property :
- loc ->
- Parsetree.expression -> string -> Parsetree.expression_desc
-val handle_debugger :
- loc -> Ast_payload.t -> Parsetree.expression_desc
-val handle_raw :
- ?check_js_regex: bool -> loc -> Ast_payload.t -> Parsetree.expression
-val handle_external :
- loc -> string -> Parsetree.expression
-
-val handle_raw_structure :
- loc -> Ast_payload.t -> Parsetree.structure_item
+let transform_test s =
+ let s_len = String.length s in
+ let buf = Buffer.create (s_len * 2) in
+ check_and_transform 0 buf s 0 s_len;
+ Buffer.contents buf
-val ocaml_obj_as_js_object :
- (Parsetree.pattern ->
- Parsetree.class_field list ->
- Parsetree.expression_desc) cxt
+let transform loc s =
+ let s_len = String.length s in
+ let buf = Buffer.create (s_len * 2) in
+ try
+ check_and_transform 0 buf s 0 s_len;
+ Buffer.contents buf
+ with
+ Error (offset, error)
+ -> Location.raise_errorf ~loc "Offset: %d, %a" offset pp_error error
- val convertBsErrorFunction :
-
- (Ast_helper.attrs -> Parsetree.case list -> Parsetree.expression) cxt
-end = struct
-#1 "ast_util.ml"
+end
+module Ast_utf8_string_interp : sig
+#1 "ast_utf8_string_interp.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -35776,787 +36874,500 @@ end = struct
* 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
-type 'a cxt = Ast_helper.loc -> Bs_ast_mapper.mapper -> 'a
-type loc = Location.t
-type args = (string * Parsetree.expression) list
-type label_exprs = (Longident.t Asttypes.loc * Parsetree.expression) list
-type uncurry_expression_gen =
- (Parsetree.pattern ->
- Parsetree.expression ->
- Parsetree.expression_desc) cxt
-type uncurry_type_gen =
- (string ->
- Parsetree.core_type ->
- Parsetree.core_type ->
- Parsetree.core_type) cxt
-
-let uncurry_type_id =
- Ast_literal.Lid.js_fn
-
-let method_id =
- Ast_literal.Lid.js_meth
-
-let method_call_back_id =
- Ast_literal.Lid.js_meth_callback
-
-let arity_lit = "Arity_"
-
-let mk_args loc n tys =
- Typ.variant ~loc
- [ Rtag (arity_lit ^ string_of_int n, [], (n = 0), tys)] Closed None
-
-let generic_lift txt loc args result =
- let xs =
- match args with
- | [ ] -> [mk_args loc 0 [] ; result ]
- | [ x ] -> [ mk_args loc 1 [x] ; result ]
- | _ ->
- [mk_args loc (List.length args ) [Typ.tuple ~loc args] ; result ]
- in
- Typ.constr ~loc {txt ; loc} xs
-
-let lift_curry_type loc =
- generic_lift uncurry_type_id loc
-
-let lift_method_type loc =
- generic_lift method_id loc
-
-let lift_js_method_callback loc
- =
- generic_lift method_call_back_id loc
-(** Note that currently there is no way to consume [Js.meth_callback]
- so it is fine to encode it with a freedom,
- but we need make it better for error message.
- - all are encoded as
- {[
- type fn = (`Args_n of _ , 'result ) Js.fn
- type method = (`Args_n of _, 'result) Js.method
- type method_callback = (`Args_n of _, 'result) Js.method_callback
- ]}
- For [method_callback], the arity is never zero, so both [method]
- and [fn] requires (unit -> 'a) to encode arity zero
-*)
-
-
-
-let arrow = Typ.arrow
-
-
-let js_property loc obj name =
- Parsetree.Pexp_send
- ((Exp.apply ~loc
- (Exp.ident ~loc
- {loc;
- txt = Ldot (Ast_literal.Lid.js_unsafe, Literals.unsafe_downgrade)})
- ["",obj]), name)
-
-(* TODO:
- have a final checking for property arities
- [#=],
-*)
-
-
-let generic_apply kind loc
- (self : Bs_ast_mapper.mapper)
- (obj : Parsetree.expression)
- (args : args ) cb =
- let obj = self.expr self obj in
- let args =
- Ext_list.map (fun (label,e) ->
- if label <> "" then
- Bs_syntaxerr.err loc Label_in_uncurried_bs_attribute;
- self.expr self e
- ) args in
- let len = List.length args in
- let arity, fn, args =
- match args with
- | [ {pexp_desc =
- Pexp_construct ({txt = Lident "()"}, None)}]
- ->
- 0, cb loc obj, []
- | _ ->
- len, cb loc obj, args in
- if arity < 10 then
- let txt =
- match kind with
- | `Fn | `PropertyFn ->
- Longident.Ldot (Ast_literal.Lid.js_unsafe,
- Literals.fn_run ^ string_of_int arity)
- | `Method ->
- Longident.Ldot(Ast_literal.Lid.js_unsafe,
- Literals.method_run ^ string_of_int arity
- ) in
- Parsetree.Pexp_apply (Exp.ident {txt ; loc}, ("",fn) :: Ext_list.map (fun x -> "",x) args)
- else
- let fn_type, args_type, result_type = Ast_comb.tuple_type_pair ~loc `Run arity in
- let string_arity = string_of_int arity in
- let pval_prim, pval_type =
- match kind with
- | `Fn | `PropertyFn ->
- ["#fn_run"; string_arity],
- arrow ~loc "" (lift_curry_type loc args_type result_type ) fn_type
- | `Method ->
- ["#method_run" ; string_arity],
- arrow ~loc "" (lift_method_type loc args_type result_type) fn_type
- in
- Ast_external_mk.local_external loc ~pval_prim ~pval_type
- (("", fn) :: Ext_list.map (fun x -> "",x) args )
-
-
-let uncurry_fn_apply loc self fn args =
- generic_apply `Fn loc self fn args (fun _ obj -> obj )
-
-let property_apply loc self obj name (args : args)
- = generic_apply `PropertyFn loc self obj args
- (fun loc obj -> Exp.mk ~loc (js_property loc obj name))
-
-let method_apply loc self obj name args =
- generic_apply `Method loc self obj args
- (fun loc obj -> Exp.mk ~loc (js_property loc obj name))
-
-let generic_to_uncurry_type kind loc (mapper : Bs_ast_mapper.mapper) label
- (first_arg : Parsetree.core_type)
- (typ : Parsetree.core_type) =
- if label <> "" then
- Bs_syntaxerr.err loc Label_in_uncurried_bs_attribute;
-
- let rec aux acc (typ : Parsetree.core_type) =
- (* in general,
- we should collect [typ] in [int -> typ] before transformation,
- however: when attributes [bs] and [bs.this] found in typ,
- we should stop
- *)
- match Ast_attributes.process_attributes_rev typ.ptyp_attributes with
- | `Nothing, _ ->
- begin match typ.ptyp_desc with
- | Ptyp_arrow (label, arg, body)
- ->
- if label <> "" then
- Bs_syntaxerr.err typ.ptyp_loc Label_in_uncurried_bs_attribute;
- aux (mapper.typ mapper arg :: acc) body
- | _ -> mapper.typ mapper typ, acc
- end
- | _, _ -> mapper.typ mapper typ, acc
- in
- let first_arg = mapper.typ mapper first_arg in
- let result, rev_extra_args = aux [first_arg] typ in
- let args = List.rev rev_extra_args in
- let filter_args args =
- match args with
- | [{Parsetree.ptyp_desc =
- (Ptyp_constr ({txt = Lident "unit"}, [])
- )}]
- -> []
- | _ -> args in
- match kind with
- | `Fn ->
- let args = filter_args args in
- lift_curry_type loc args result
- | `Method ->
- let args = filter_args args in
- lift_method_type loc args result
-
- | `Method_callback
- -> lift_js_method_callback loc args result
-
-let to_uncurry_type =
- generic_to_uncurry_type `Fn
-let to_method_type =
- generic_to_uncurry_type `Method
-let to_method_callback_type =
- generic_to_uncurry_type `Method_callback
-
-let generic_to_uncurry_exp kind loc (self : Bs_ast_mapper.mapper) pat body
- =
- let rec aux acc (body : Parsetree.expression) =
- match Ast_attributes.process_attributes_rev body.pexp_attributes with
- | `Nothing, _ ->
- begin match body.pexp_desc with
- | Pexp_fun (label,_, arg, body)
- ->
- if label <> "" then
- Bs_syntaxerr.err loc Label_in_uncurried_bs_attribute;
- aux (self.pat self arg :: acc) body
- | _ -> self.expr self body, acc
- end
- | _, _ -> self.expr self body, acc
- in
- let first_arg = self.pat self pat in
- let () =
- match kind with
- | `Method_callback ->
- if not @@ Ast_pat.is_single_variable_pattern_conservative first_arg then
- Bs_syntaxerr.err first_arg.ppat_loc Bs_this_simple_pattern
- | _ -> ()
- in
+type kind =
+ | String
+ | Var
+type error = private
+ | Invalid_code_point
+ | Unterminated_backslash
+ | Invalid_escape_code of char
+ | Invalid_hex_escape
+ | Invalid_unicode_escape
+ | Unterminated_variable
+ | Unmatched_paren
+ | Invalid_syntax_of_var of string
- let result, rev_extra_args = aux [first_arg] body in
- let body =
- List.fold_left (fun e p -> Ast_comb.fun_no_label ~loc p e )
- result rev_extra_args in
- let len = List.length rev_extra_args in
- let arity =
- match kind with
- | `Fn ->
- begin match rev_extra_args with
- | [ p]
- ->
- Ast_pat.is_unit_cont ~yes:0 ~no:len p
+(** Note the position is about code point *)
+type pos = { lnum : int ; offset : int ; byte_bol : int }
- | _ -> len
- end
- | `Method_callback -> len in
- if arity < 10 then
- let txt =
- match kind with
- | `Fn ->
- Longident.Ldot ( Ast_literal.Lid.js_unsafe, Literals.fn_mk ^ string_of_int arity)
- | `Method_callback ->
- Longident.Ldot (Ast_literal.Lid.js_unsafe, Literals.fn_method ^ string_of_int arity) in
- Parsetree.Pexp_apply (Exp.ident {txt;loc} , ["",body])
+type segment = {
+ start : pos;
+ finish : pos ;
+ kind : kind;
+ content : string ;
+}
- else
- let pval_prim =
- [ (match kind with
- | `Fn -> "#fn_mk"
- | `Method_callback -> "#fn_method");
- string_of_int arity] in
- let fn_type , args_type, result_type = Ast_comb.tuple_type_pair ~loc `Make arity in
- let pval_type = arrow ~loc "" fn_type (
- match kind with
- | `Fn ->
- lift_curry_type loc args_type result_type
- | `Method_callback ->
- lift_js_method_callback loc args_type result_type
- ) in
- Ast_external_mk.local_extern_cont loc ~pval_prim ~pval_type
- (fun prim -> Exp.apply ~loc prim ["", body])
+type segments = segment list
-let to_uncurry_fn =
- generic_to_uncurry_exp `Fn
-let to_method_callback =
- generic_to_uncurry_exp `Method_callback
+type cxt = {
+ mutable segment_start : pos ;
+ buf : Buffer.t ;
+ s_len : int ;
+ mutable segments : segments;
+ mutable pos_bol : int; (* record the abs position of current beginning line *)
+ mutable byte_bol : int ;
+ mutable pos_lnum : int ; (* record the line number *)
+}
+type exn += Error of pos * pos * error
-let handle_debugger loc payload =
- if Ast_payload.as_empty_structure payload then
- Parsetree.Pexp_apply
- (Exp.ident {txt = Ldot(Ast_literal.Lid.js_unsafe, Literals.debugger ); loc},
- ["", Ast_literal.val_unit ~loc ()])
- else Location.raise_errorf ~loc "bs.raw can only be applied to a string"
+val empty_segment : segment -> bool
+val transform_test : string -> segment list
+val transform_interp : Location.t -> string -> Parsetree.expression
-let handle_raw ?(check_js_regex = false) loc payload =
- begin match Ast_payload.as_string_exp ~check_js_regex payload with
- | Not_String_Lteral ->
- Location.raise_errorf ~loc
- "bs.raw can only be applied to a string"
- | Ast_payload.JS_Regex_Check_Failed ->
- Location.raise_errorf ~loc "this is an invalid js regex"
- | Correct exp ->
- let pexp_desc =
- Parsetree.Pexp_apply (
- Exp.ident {loc;
- txt =
- Ldot (Ast_literal.Lid.js_unsafe,
- Literals.raw_expr)},
- ["",exp]
- )
- in
- { exp with pexp_desc }
- end
+end = struct
+#1 "ast_utf8_string_interp.ml"
+(* 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 handle_external loc x =
- let raw_exp : Ast_exp.t =
- Ast_helper.Exp.apply
- (Exp.ident ~loc
- {loc; txt = Ldot (Ast_literal.Lid.js_unsafe,
- Literals.raw_expr)})
- ~loc
- [Ext_string.empty,
- Exp.constant ~loc (Const_string (x,Some Ext_string.empty))] in
- let empty =
- Exp.ident ~loc
- {txt = Ldot (Ldot(Lident"Js", "Undefined"), "empty");loc}
- in
- let undefined_typeof =
- Exp.ident {loc ; txt = Ldot(Lident "Js","undefinedToOption")} in
- let typeof =
- Exp.ident {loc ; txt = Ldot(Lident "Js","typeof")} in
+type error =
+ | Invalid_code_point
+ | Unterminated_backslash
+ | Invalid_escape_code of char
+ | Invalid_hex_escape
+ | Invalid_unicode_escape
+ | Unterminated_variable
+ | Unmatched_paren
+ | Invalid_syntax_of_var of string
+type kind =
+ | String
+ | Var
- Exp.apply ~loc undefined_typeof [
- Ext_string.empty,
- Exp.ifthenelse ~loc
- (Exp.apply ~loc
- (Exp.ident ~loc {loc ; txt = Ldot (Lident "Pervasives", "=")} )
- [
- Ext_string.empty,
- (Exp.apply ~loc typeof [Ext_string.empty,raw_exp]);
- Ext_string.empty,
- Exp.constant ~loc (Const_string ("undefined",None))
- ])
- (empty)
- (Some raw_exp)
- ]
+(** Note the position is about code point *)
+type pos = {
+ lnum : int ;
+ offset : int ;
+ byte_bol : int (* Note it actually needs to be in sync with OCaml's lexing semantics *)
+}
-let handle_raw_structure loc payload =
- begin match Ast_payload.as_string_exp payload with
- | Correct exp
- ->
- let pexp_desc =
- Parsetree.Pexp_apply(
- Exp.ident {txt = Ldot (Ast_literal.Lid.js_unsafe, Literals.raw_stmt); loc},
- ["",exp]) in
- Ast_helper.Str.eval
- { exp with pexp_desc }
- | Not_String_Lteral
- ->
- Location.raise_errorf ~loc "bs.raw can only be applied to a string"
- | JS_Regex_Check_Failed
- ->
- Location.raise_errorf ~loc "this is an invalid js regex"
- end
+type segment = {
+ start : pos;
+ finish : pos ;
+ kind : kind;
+ content : string ;
+}
+type segments = segment list
-let ocaml_obj_as_js_object
- loc (mapper : Bs_ast_mapper.mapper)
- (self_pat : Parsetree.pattern)
- (clfs : Parsetree.class_field list) =
- let self_type_lit = "self_type" in
- (** Attention: we should avoid type variable conflict for each method
- Since the method name is unique, there would be no conflict
- OCaml does not allow duplicate instance variable and duplicate methods,
- but it does allow duplicates between instance variable and method name,
- we should enforce such rules
- {[
- object
- val x = 3
- method x = 3
- end [@bs]
- ]} should not compile with a meaningful error message
- *)
+type cxt = {
+ mutable segment_start : pos ;
+ buf : Buffer.t ;
+ s_len : int ;
+ mutable segments : segments;
+ mutable pos_bol : int; (* record the abs position of current beginning line *)
+ mutable byte_bol : int ;
+ mutable pos_lnum : int ; (* record the line number *)
+}
- let generate_val_method_pair
- loc (mapper : Bs_ast_mapper.mapper)
- val_name is_mutable =
- let result = Typ.var ~loc val_name in
- result ,
- ((val_name , [], result ) ::
- (if is_mutable then
- [val_name ^ Literals.setter_suffix,[],
- to_method_type loc mapper "" result (Ast_literal.type_unit ~loc ()) ]
- else
- []) )
- in
- (* Note mapper is only for API compatible
- * TODO: we should check label name to avoid conflict
- *)
- let self_type loc = Typ.var ~loc self_type_lit in
+type exn += Error of pos * pos * error
- let generate_arg_type loc (mapper : Bs_ast_mapper.mapper)
- method_name arity : Ast_core_type.t =
- let result = Typ.var ~loc method_name in
- if arity = 0 then
- to_method_type loc mapper "" (Ast_literal.type_unit ~loc ()) result
+let pp_error fmt err =
+ Format.pp_print_string fmt @@ match err with
+ | Invalid_code_point -> "Invalid code point"
+ | Unterminated_backslash -> "\\ ended unexpectedly"
+ | Invalid_escape_code c -> "Invalid escape code: " ^ String.make 1 c
+ | Invalid_hex_escape ->
+ "Invalid \\x escape"
+ | Invalid_unicode_escape -> "Invalid \\u escape"
+ | Unterminated_variable -> "$ unterminated"
+ | Unmatched_paren -> "Unmatched paren"
+ | Invalid_syntax_of_var s -> "`" ^s ^ "' is not a valid syntax of interpolated identifer"
+let valid_lead_identifier_char x =
+ match x with
+ | 'a'..'z' | '_' -> true
+ | _ -> false
- else
- let tyvars =
- Ext_list.init arity (fun i -> Typ.var ~loc (method_name ^ string_of_int i))
- in
- begin match tyvars with
- | x :: rest ->
- let method_rest =
- Ext_list.fold_right (fun v acc -> Typ.arrow ~loc "" v acc)
- rest result in
- to_method_type loc mapper "" x method_rest
- | _ -> assert false
- end in
+let valid_identifier_char x =
+ match x with
+ | 'a'..'z'
+ | 'A'..'Z'
+ | '0'..'9'
+ | '_' | '\''-> true
+ | _ -> false
+(** Invariant: [valid_lead_identifier] has to be [valid_identifier] *)
- let generate_method_type
- loc
- (mapper : Bs_ast_mapper.mapper)
- ?alias_type method_name arity =
- let result = Typ.var ~loc method_name in
+let valid_identifier s =
+ let s_len = String.length s in
+ if s_len = 0 then false
+ else
+ valid_lead_identifier_char s.[0] &&
+ Ext_string.for_all_from s 1 valid_identifier_char
- let self_type =
- let v = self_type loc in
- match alias_type with
- | None -> v
- | Some ty -> Typ.alias ~loc ty self_type_lit
- in
- if arity = 0 then
- to_method_callback_type loc mapper "" self_type result
- else
- let tyvars =
- Ext_list.init arity (fun i -> Typ.var ~loc (method_name ^ string_of_int i))
- in
- begin match tyvars with
- | x :: rest ->
- let method_rest =
- Ext_list.fold_right (fun v acc -> Typ.arrow ~loc "" v acc)
- rest result in
- (to_method_callback_type loc mapper "" self_type
- (Typ.arrow ~loc "" x method_rest))
- | _ -> assert false
- end in
+
+let is_space x =
+ match x with
+ | ' ' | '\n' | '\t' -> true
+ | _ -> false
- (** we need calculate the real object type
- and exposed object type, in some cases there are equivalent
- for public object type its [@bs.meth] it does not depend on itself
- while for label argument it is [@bs.this] which depends internal object
- *)
- let internal_label_attr_types, public_label_attr_types =
- Ext_list.fold_right
- (fun ({pcf_loc = loc} as x : Parsetree.class_field)
- (label_attr_types, public_label_attr_types) ->
- match x.pcf_desc with
- | Pcf_method (
- label,
- public_flag,
- Cfk_concrete
- (Fresh, e))
- ->
- begin match e.pexp_desc with
- | Pexp_poly
- (({pexp_desc = Pexp_fun ("", None, pat, e)} ),
- None) ->
- let arity = Ast_pat.arity_of_fun pat e in
- let method_type =
- generate_arg_type x.pcf_loc mapper label.txt arity in
- ((label.Asttypes.txt, [], method_type) :: label_attr_types),
- (if public_flag = Public then
- (label.Asttypes.txt, [], method_type) :: public_label_attr_types
- else
- public_label_attr_types)
+(**
+ FIXME: multiple line offset
+ if there is no line offset. Note {|{j||} border will never trigger a new line
+*)
+let update_position border
+ ({lnum ; offset;byte_bol } : pos)
+ (pos : Lexing.position)=
+ if lnum = 0 then
+ {pos with pos_cnum = pos.pos_cnum + border + offset }
+ (** When no newline, the column number is [border + offset] *)
+ else
+ {
+ pos with
+ pos_lnum = pos.pos_lnum + lnum ;
+ pos_bol = pos.pos_cnum + border + byte_bol;
+ pos_cnum = pos.pos_cnum + border + byte_bol + offset;
+ (** when newline, the column number is [offset] *)
+ }
+let update border
+ (start : pos)
+ (finish : pos) (loc : Location.t) : Location.t =
+ let start_pos = loc.loc_start in
+ { loc with
+ loc_start =
+ update_position border start start_pos;
+ loc_end =
+ update_position border finish start_pos
+ }
- | Pexp_poly( _, Some _)
- ->
- Location.raise_errorf ~loc "polymorphic type annotation not supported yet"
- | Pexp_poly (_, None) ->
- Location.raise_errorf ~loc
- "Unsupported syntax, expect syntax like `method x () = x ` "
- | _ ->
- Location.raise_errorf ~loc "Unsupported syntax in js object"
- end
- | Pcf_val (label, mutable_flag, Cfk_concrete(Fresh, val_exp)) ->
- let label_type, label_attr =
- generate_val_method_pair x.pcf_loc mapper label.txt
- (mutable_flag = Mutable )
- in
- (Ext_list.append label_attr label_attr_types, public_label_attr_types)
- | Pcf_val (label, mutable_flag, Cfk_concrete(Override, val_exp)) ->
- Location.raise_errorf ~loc "override flag not support currently"
- | Pcf_val (label, mutable_flag, Cfk_virtual _) ->
- Location.raise_errorf ~loc "virtual flag not support currently"
- | Pcf_method (_, _, Cfk_concrete(Override, _) ) ->
- Location.raise_errorf ~loc "override flag not supported"
+(** Note [Var] kind can not be mpty *)
+let empty_segment {content } =
+ Ext_string.is_empty content
- | Pcf_method (_, _, Cfk_virtual _ )
- ->
- Location.raise_errorf ~loc "virtural method not supported"
- | Pcf_inherit _
- | Pcf_initializer _
- | Pcf_attribute _
- | Pcf_extension _
- | Pcf_constraint _ ->
- Location.raise_errorf ~loc "Only method support currently"
- ) clfs ([], []) in
- let internal_obj_type = Ast_core_type.make_obj ~loc internal_label_attr_types in
- let public_obj_type = Ast_core_type.make_obj ~loc public_label_attr_types in
- let (labels, label_types, exprs, _) =
- Ext_list.fold_right
- (fun (x : Parsetree.class_field)
- (labels,
- label_types,
- exprs, aliased ) ->
- match x.pcf_desc with
- | Pcf_method (
- label,
- _public_flag,
- Cfk_concrete
- (Fresh, e))
- ->
- begin match e.pexp_desc with
- | Pexp_poly
- (({pexp_desc = Pexp_fun ("", None, pat, e)} as f),
- None) ->
- let arity = Ast_pat.arity_of_fun pat e in
- let alias_type =
- if aliased then None
- else Some internal_obj_type in
- let label_type =
- generate_method_type ?alias_type
- x.pcf_loc mapper label.txt arity in
- (label::labels,
- label_type::label_types,
- {f with
- pexp_desc =
- let f = Ast_pat.is_unit_cont pat ~yes:e ~no:f in
- to_method_callback loc mapper self_pat f
- } :: exprs,
- true
- )
- | Pexp_poly( _, Some _)
- ->
- Location.raise_errorf ~loc
- "polymorphic type annotation not supported yet"
- | Pexp_poly (_, None) ->
- Location.raise_errorf
- ~loc "Unsupported syntax, expect syntax like `method x () = x ` "
- | _ ->
- Location.raise_errorf ~loc "Unsupported syntax in js object"
- end
- | Pcf_val (label, mutable_flag, Cfk_concrete(Fresh, val_exp)) ->
- let label_type, label_attr =
- generate_val_method_pair x.pcf_loc mapper label.txt
- (mutable_flag = Mutable )
- in
- (label::labels,
- label_type :: label_types,
- (mapper.expr mapper val_exp :: exprs),
- aliased
- )
+let update_newline ~byte_bol loc cxt =
+ cxt.pos_lnum <- cxt.pos_lnum + 1 ;
+ cxt.pos_bol <- loc;
+ cxt.byte_bol <- byte_bol
- | Pcf_val (label, mutable_flag, Cfk_concrete(Override, val_exp)) ->
- Location.raise_errorf ~loc "override flag not support currently"
- | Pcf_val (label, mutable_flag, Cfk_virtual _) ->
- Location.raise_errorf ~loc "virtual flag not support currently"
+let pos_error cxt ~loc error =
+ raise (Error
+ (cxt.segment_start,
+ { lnum = cxt.pos_lnum ; offset = loc - cxt.pos_bol ; byte_bol = cxt.byte_bol}, error))
- | Pcf_method (_, _, Cfk_concrete(Override, _) ) ->
- Location.raise_errorf ~loc "override flag not supported"
+let add_var_segment cxt loc =
+ let content = Buffer.contents cxt.buf in
+ Buffer.clear cxt.buf ;
+ let next_loc = {
+ lnum = cxt.pos_lnum ; offset = loc - cxt.pos_bol ;
+ byte_bol = cxt.byte_bol } in
+ if valid_identifier content then
+ begin
+ cxt.segments <-
+ { start = cxt.segment_start;
+ finish = next_loc ;
+ kind = Var;
+ content} :: cxt.segments ;
+ cxt.segment_start <- next_loc
+ end
+ else pos_error cxt ~loc (Invalid_syntax_of_var content)
- | Pcf_method (_, _, Cfk_virtual _ )
- ->
- Location.raise_errorf ~loc "virtural method not supported"
+let add_str_segment cxt loc =
+ let content = Buffer.contents cxt.buf in
+ Buffer.clear cxt.buf ;
+ let next_loc = {
+ lnum = cxt.pos_lnum ; offset = loc - cxt.pos_bol ;
+ byte_bol = cxt.byte_bol } in
+ cxt.segments <-
+ { start = cxt.segment_start;
+ finish = next_loc ;
+ kind = String;
+ content} :: cxt.segments ;
+ cxt.segment_start <- next_loc
- | Pcf_inherit _
- | Pcf_initializer _
- | Pcf_attribute _
- | Pcf_extension _
- | Pcf_constraint _ ->
- Location.raise_errorf ~loc "Only method support currently"
- ) clfs ([], [], [], false) in
- let pval_type =
- Ext_list.fold_right2
- (fun label label_type acc ->
- Typ.arrow
- ~loc:label.Asttypes.loc
- label.Asttypes.txt
- label_type acc
- ) labels label_types public_obj_type in
- Ast_external_mk.local_extern_cont
- loc
- ~pval_prim:(External_process.pval_prim_of_labels labels)
- (fun e ->
- Exp.apply ~loc e
- (Ext_list.map2 (fun l expr -> l.Asttypes.txt, expr) labels exprs) )
- ~pval_type
+
+
+
+let rec check_and_transform (loc : int ) s byte_offset ({s_len; buf} as cxt : cxt) =
+ if byte_offset = s_len then
+ add_str_segment cxt loc
+ else
+ let current_char = s.[byte_offset] in
+ match Ext_utf8.classify current_char with
+ | Single 92 (* '\\' *) ->
+ escape_code (loc + 1) s (byte_offset+1) cxt
+ | Single 34 ->
+ Buffer.add_string buf "\\\"";
+ check_and_transform (loc + 1) s (byte_offset + 1) cxt
+ | Single 39 ->
+ Buffer.add_string buf "\\'";
+ check_and_transform (loc + 1) s (byte_offset + 1) cxt
+ | Single 10 ->
+ Buffer.add_string buf "\\n";
+ let loc = loc + 1 in
+ let byte_offset = byte_offset + 1 in
+ update_newline ~byte_bol:byte_offset loc cxt ; (* Note variable could not have new-line *)
+ check_and_transform loc s byte_offset cxt
+ | Single 13 ->
+ Buffer.add_string buf "\\r";
+ check_and_transform (loc + 1) s (byte_offset + 1) cxt
+ | Single 36 -> (* $ *)
+ add_str_segment cxt loc ;
+ let offset = byte_offset + 1 in
+ if offset >= s_len then
+ pos_error ~loc cxt Unterminated_variable
+ else
+ let cur_char = s.[offset] in
+ if cur_char = '(' then
+ expect_var_paren (loc + 2) s (offset + 1) cxt
+ else
+ expect_simple_var (loc + 1) s offset cxt
+ | Single _ ->
+ Buffer.add_char buf current_char;
+ check_and_transform (loc + 1) s (byte_offset + 1) cxt
-let record_as_js_object
- loc
- (self : Bs_ast_mapper.mapper)
- (label_exprs : label_exprs)
- : Parsetree.expression_desc =
+ | Invalid
+ | Cont _ -> pos_error ~loc cxt Invalid_code_point
+ | Leading (n,_) ->
+ let i' = Ext_utf8.next s ~remaining:n byte_offset in
+ if i' < 0 then
+ pos_error cxt ~loc Invalid_code_point
+ else
+ begin
+ for k = byte_offset to i' do
+ Buffer.add_char buf s.[k];
+ done;
+ check_and_transform (loc + 1 ) s (i' + 1) cxt
+ end
+(**Lets keep identifier simple, so that we could generating a function easier in the future
+ for example
+ let f = [%fn{| $x + $y = $x_add_y |}]
+*)
+and expect_simple_var loc s offset ({buf; s_len} as cxt) =
+ let v = ref offset in
+ (* prerr_endline @@ Ext_pervasives.dump (s, has_paren, (is_space s.[!v]), !v); *)
+ if not (offset < s_len && valid_lead_identifier_char s.[offset]) then
+ pos_error cxt ~loc (Invalid_syntax_of_var Ext_string.empty)
+ else
+ begin
+ while !v < s_len && valid_identifier_char s.[!v] do (* TODO*)
+ let cur_char = s.[!v] in
+ Buffer.add_char buf cur_char;
+ incr v ;
+ done;
+ let added_length = !v - offset in
+ let loc = added_length + loc in
+ add_var_segment cxt loc ;
+ check_and_transform loc s (added_length + offset) cxt
+ end
+and expect_var_paren loc s offset ({buf; s_len} as cxt) =
+ let v = ref offset in
+ (* prerr_endline @@ Ext_pervasives.dump (s, has_paren, (is_space s.[!v]), !v); *)
+ while !v < s_len && s.[!v] <> ')' do
+ let cur_char = s.[!v] in
+ Buffer.add_char buf cur_char;
+ incr v ;
+ done;
+ let added_length = !v - offset in
+ let loc = added_length + 1 + loc in
+ if !v < s_len && s.[!v] = ')' then
+ begin
+ add_var_segment cxt loc ;
+ check_and_transform loc s (added_length + 1 + offset) cxt
+ end
+ else
+ pos_error cxt ~loc Unmatched_paren
- let labels,args, arity =
- Ext_list.fold_right (fun ({Location.txt ; loc}, e) (labels,args,i) ->
- match txt with
- | Longident.Lident x ->
- ({Asttypes.loc = loc ; txt = x} :: labels, (x, self.expr self e) :: args, i + 1)
- | Ldot _ | Lapply _ ->
- Location.raise_errorf ~loc "invalid js label ") label_exprs ([],[],0) in
- Ast_external_mk.local_external loc
- ~pval_prim:(External_process.pval_prim_of_labels labels)
- ~pval_type:(Ast_core_type.from_labels ~loc arity labels)
- args
-let isCamlExceptionOrOpenVariant = Longident.parse "Caml_exceptions.isCamlExceptionOrOpenVariant"
-let obj_magic = Longident.parse "Obj.magic"
-let rec checkCases (cases : Parsetree.case list) =
- List.iter check_case cases
-and check_case case =
- check_pat case.pc_lhs
-and check_pat (pat : Parsetree.pattern) =
- match pat.ppat_desc with
- | Ppat_construct _ -> ()
- | Ppat_or (l,r) ->
- check_pat l; check_pat r
- | _ -> Location.raise_errorf ~loc:pat.ppat_loc "Unsupported pattern in `bs.open`"
+(* we share the same escape sequence with js *)
+and escape_code loc s offset ({ buf; s_len} as cxt) =
+ if offset >= s_len then
+ pos_error cxt ~loc Unterminated_backslash
+ else
+ Buffer.add_char buf '\\';
+ let cur_char = s.[offset] in
+ match cur_char with
+ | '\\'
+ | 'b'
+ | 't'
+ | 'n'
+ | 'v'
+ | 'f'
+ | 'r'
+ | '0'
+ | '$'
+ ->
+ begin
+ Buffer.add_char buf cur_char ;
+ check_and_transform (loc + 1) s (offset + 1) cxt
+ end
+ | 'u' ->
+ begin
+ Buffer.add_char buf cur_char;
+ unicode (loc + 1) s (offset + 1) cxt
+ end
+ | 'x' -> begin
+ Buffer.add_char buf cur_char ;
+ two_hex (loc + 1) s (offset + 1) cxt
+ end
+ | _ -> pos_error cxt ~loc (Invalid_escape_code cur_char)
+and two_hex loc s offset ({buf ; s_len} as cxt) =
+ if offset + 1 >= s_len then
+ pos_error cxt ~loc Invalid_hex_escape;
+ let a, b = s.[offset], s.[offset + 1] in
+ if Ext_char.valid_hex a && Ext_char.valid_hex b then
+ begin
+ Buffer.add_char buf a ;
+ Buffer.add_char buf b ;
+ check_and_transform (loc + 2) s (offset + 2) cxt
+ end
+ else
+ pos_error cxt ~loc Invalid_hex_escape
-let convertBsErrorFunction loc (self : Bs_ast_mapper.mapper) attrs (cases : Parsetree.case list ) =
- let txt = "match" in
- let txt_expr = Exp.ident ~loc {txt = Lident txt; loc} in
- let none = Exp.constraint_ ~loc
- (Exp.construct ~loc {txt = Lident "None" ; loc} None)
- (Ast_core_type.lift_option_type (Typ.any ~loc ())) in
- let () = checkCases cases in
- let cases = self.cases self cases in
- Exp.fun_ ~attrs ~loc "" None ( Pat.var ~loc {txt; loc })
- (Exp.ifthenelse
- ~loc
- (Exp.apply ~loc (Exp.ident ~loc {txt = isCamlExceptionOrOpenVariant ; loc}) ["", txt_expr ])
- (Exp.match_ ~loc
- (Exp.constraint_ ~loc
- (Exp.apply ~loc (Exp.ident ~loc {txt = obj_magic; loc}) ["", txt_expr])
- (Ast_literal.type_exn ~loc ())
- )
- (Ext_list.map_append (fun (x :Parsetree.case ) ->
- let pc_rhs = x.pc_rhs in
- let loc = pc_rhs.pexp_loc in
- {
- x with pc_rhs =
- Exp.constraint_ ~loc
- (Exp.construct ~loc {txt = Lident "Some";loc} (Some pc_rhs))
- (Ast_core_type.lift_option_type (Typ.any ~loc ()) )
- }
- ) cases
- [
- Exp.case (Pat.any ~loc ()) none
- ])
- )
- (Some none))
-
-
+and unicode loc s offset ({buf ; s_len} as cxt) =
+ if offset + 3 >= s_len then
+ pos_error cxt ~loc Invalid_unicode_escape
+ ;
+ let a0,a1,a2,a3 = s.[offset], s.[offset+1], s.[offset+2], s.[offset+3] in
+ if
+ Ext_char.valid_hex a0 &&
+ Ext_char.valid_hex a1 &&
+ Ext_char.valid_hex a2 &&
+ Ext_char.valid_hex a3 then
+ begin
+ Buffer.add_char buf a0;
+ Buffer.add_char buf a1;
+ Buffer.add_char buf a2;
+ Buffer.add_char buf a3;
+ check_and_transform (loc + 4) s (offset + 4) cxt
+ end
+ else
+ pos_error cxt ~loc Invalid_unicode_escape
+let transform_test s =
+ let s_len = String.length s in
+ let buf = Buffer.create (s_len * 2) in
+ let cxt =
+ { segment_start = {lnum = 0; offset = 0; byte_bol = 0};
+ buf ;
+ s_len;
+ segments = [];
+ pos_lnum = 0;
+ byte_bol = 0;
+ pos_bol = 0;
-end
-module Ext_ref : sig
-#1 "ext_ref.mli"
-(* 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. *)
+ } in
+ check_and_transform 0 s 0 cxt;
+ List.rev cxt.segments
-(** [non_exn_protect ref value f] assusme [f()]
- would not raise
-*)
-val non_exn_protect : 'a ref -> 'a -> (unit -> 'b) -> 'b
-val protect : 'a ref -> 'a -> (unit -> 'b) -> 'b
+(** TODO: test empty var $() $ failure,
+ Allow identifers x.A.y *)
+
+open Ast_helper
-val protect2 : 'a ref -> 'b ref -> 'a -> 'b -> (unit -> 'c) -> 'c
+(** Longident.parse "Pervasives.^" *)
+let concat_ident : Longident.t =
+ Ldot (Lident "Pervasives", "^")
+ (* JS string concatMany *)
+ (* Ldot (Ldot (Lident "Js", "String"), "concat") *)
-(** [non_exn_protect2 refa refb va vb f ]
- assume [f ()] would not raise
-*)
-val non_exn_protect2 : 'a ref -> 'b ref -> 'a -> 'b -> (unit -> 'c) -> 'c
+(* Longident.parse "Js.String.make" *)
+let to_string_ident : Longident.t =
+ Ldot (Ldot (Lident "Js", "String"), "make")
-val protect_list : ('a ref * 'a) list -> (unit -> 'b) -> 'b
-end = struct
-#1 "ext_ref.ml"
-(* 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 non_exn_protect r v body =
- let old = !r in
- r := v;
- let res = body() in
- r := old;
- res
+let escaped = Some Literals.escaped_j_delimiter
-let protect r v body =
- let old = !r in
- try
- r := v;
- let res = body() in
- r := old;
- res
- with x ->
- r := old;
- raise x
+let concat_exp
+ (a : Parsetree.expression)
+ (b : Parsetree.expression) : Parsetree.expression =
+ let loc = Bs_loc.merge a.pexp_loc b.pexp_loc in
+ Exp.apply ~loc
+ (Exp.ident { txt =concat_ident; loc})
+ ["",a ;
+ "",b]
-let non_exn_protect2 r1 r2 v1 v2 body =
- let old1 = !r1 in
- let old2 = !r2 in
- r1 := v1;
- r2 := v2;
- let res = body() in
- r1 := old1;
- r2 := old2;
- res
+let border = String.length "{j|"
-let protect2 r1 r2 v1 v2 body =
- let old1 = !r1 in
- let old2 = !r2 in
- try
- r1 := v1;
- r2 := v2;
- let res = body() in
- r1 := old1;
- r2 := old2;
- res
- with x ->
- r1 := old1;
- r2 := old2;
- raise x
+let aux loc (segment : segment) =
+ match segment with
+ | {start ; finish; kind ; content}
+ ->
+ let loc = update border start finish loc in
+ begin match kind with
+ | String ->
+ Exp.constant
+ ~loc
+ (Const_string (content, escaped))
+ | Var ->
+ Exp.apply ~loc
+ (Exp.ident ~loc {loc ; txt = to_string_ident })
+ [
+ "",
+ Exp.ident ~loc {loc ; txt = Lident content}
+ ]
+ end
-let protect_list rvs body =
- let olds = Ext_list.map (fun (x,y) -> !x) rvs in
- let () = List.iter (fun (x,y) -> x:=y) rvs in
+
+let transform_interp loc s =
+ let s_len = String.length s in
+ let buf = Buffer.create (s_len * 2 ) in
try
- let res = body () in
- List.iter2 (fun (x,_) old -> x := old) rvs olds;
- res
- with e ->
- List.iter2 (fun (x,_) old -> x := old) rvs olds;
- raise e
+ let cxt : cxt =
+ { segment_start = {lnum = 0; offset = 0; byte_bol = 0};
+ buf ;
+ s_len;
+ segments = [];
+ pos_lnum = 0;
+ byte_bol = 0;
+ pos_bol = 0;
+
+ } in
+
+ check_and_transform 0 s 0 cxt;
+ let rev_segments = cxt.segments in
+ match rev_segments with
+ | [] ->
+ Exp.constant ~loc
+ (Const_string ("", Some Literals.escaped_j_delimiter))
+ | [ segment] ->
+ aux loc segment
+ | a::rest ->
+ List.fold_left (fun (acc : Parsetree.expression)
+ (x : segment) ->
+ concat_exp (aux loc x) acc )
+ (aux loc a) rest
+ with
+ Error (start,pos, error)
+ ->
+ Location.raise_errorf ~loc:(update border start pos loc )
+ "%a" pp_error error
end
module Ppx_entry : sig
@@ -36664,478 +37475,70 @@ end = struct
(* When we design a ppx, we should keep it simple, and also think about
how it would work with other tools like merlin and ocamldep *)
-(**
- 1. extension point
- {[
- [%bs.raw{| blabla |}]
- ]}
- will be desugared into
- {[
- let module Js =
- struct unsafe_js : string -> 'a end
- in Js.unsafe_js {| blabla |}
- ]}
- The major benefit is to better error reporting (with locations).
- Otherwise
-
- {[
-
- let f u = Js.unsafe_js u
- let _ = f (1 + 2)
- ]}
- And if it is inlined some where
-*)
-
-
-
-open Ast_helper
-
-
-
-
-let record_as_js_object = ref false (* otherwise has an attribute *)
-let no_export = ref false
-
-let () =
- Ast_derive_projector.init ();
- Ast_derive_js_mapper.init ()
-
-let reset () =
- record_as_js_object := false ;
- no_export := false
-
-let rec is_simple_pattern (p : Parsetree.pattern) =
- match p.ppat_desc with
- | Ppat_any -> true
- | Ppat_var _ -> true
- | Ppat_constraint(p,_) -> is_simple_pattern p
- | _ -> false
-
-let rec destruct
- acc (e : Parsetree.expression) =
- match e.pexp_desc with
- | Pexp_open (flag, lid, cont)
- ->
- destruct
- ((flag, lid, e.pexp_loc, e.pexp_attributes) :: acc)
- cont
- | Pexp_tuple es -> Some (acc, es)
- | _ -> None
-
-let newTdcls tdcls newAttrs =
- match tdcls with
- | [ x ] ->
- [{ x with Parsetree.ptype_attributes = newAttrs}]
- | _ ->
- Ext_list.map_last
- (fun last x ->
- if last then { x with Parsetree.ptype_attributes = newAttrs} else x )
- tdcls
-(*
- [let (a,b) = M.N.(c,d) ]
- =>
- [ let a = M.N.c
- and b = M.N.d ]
-*)
-let flattern_tuple_pattern_vb
- (self : Bs_ast_mapper.mapper)
- ({pvb_loc } as vb : Parsetree.value_binding)
- acc : Parsetree.value_binding list =
- let pvb_pat = self.pat self vb.pvb_pat in
- let pvb_expr = self.expr self vb.pvb_expr in
- let pvb_attributes = self.attributes self vb.pvb_attributes in
- match destruct [] pvb_expr, pvb_pat.ppat_desc with
- | Some (wholes, es), Ppat_tuple xs
- when
- List.for_all is_simple_pattern xs &&
- Ext_list.same_length es xs
- ->
- (Ext_list.fold_right2 (fun pat exp acc->
- {Parsetree.
- pvb_pat =
- pat;
- pvb_expr =
- ( match wholes with
- | [] -> exp
- | _ ->
- List.fold_left (fun x (flag,lid,loc,attrs) ->
- {Parsetree.
- pexp_desc = Pexp_open(flag,lid,x);
- pexp_attributes = attrs;
- pexp_loc = loc
- }
- ) exp wholes) ;
- pvb_attributes;
- pvb_loc ;
- } :: acc
- ) xs es) acc
- | _ ->
- {pvb_pat ;
- pvb_expr ;
- pvb_loc ;
- pvb_attributes} :: acc
+(**
+ 1. extension point
+ {[
+ [%bs.raw{| blabla |}]
+ ]}
+ will be desugared into
+ {[
+ let module Js =
+ struct unsafe_js : string -> 'a end
+ in Js.unsafe_js {| blabla |}
+ ]}
+ The major benefit is to better error reporting (with locations).
+ Otherwise
+ {[
+ let f u = Js.unsafe_js u
+ let _ = f (1 + 2)
+ ]}
+ And if it is inlined some where
+*)
-let process_getter_setter ~no ~get ~set
- loc name
- (attrs : Ast_attributes.t)
- (ty : Parsetree.core_type) acc =
- match Ast_attributes.process_method_attributes_rev attrs with
- | {get = None; set = None}, _ -> no ty :: acc
- | st , pctf_attributes
- ->
- let get_acc =
- match st.set with
- | Some `No_get -> acc
- | None
- | Some `Get ->
- let lift txt =
- Typ.constr ~loc {txt ; loc} [ty] in
- let (null,undefined) =
- match st with
- | {get = Some (null, undefined) } -> (null, undefined)
- | {get = None} -> (false, false ) in
- let ty =
- match (null,undefined) with
- | false, false -> ty
- | true, false -> lift Ast_literal.Lid.js_null
- | false, true -> lift Ast_literal.Lid.js_undefined
- | true , true -> lift Ast_literal.Lid.js_null_undefined in
- get ty name pctf_attributes
- :: acc
- in
- if st.set = None then get_acc
- else
- set ty (name ^ Literals.setter_suffix) pctf_attributes
- :: get_acc
+open Ast_helper
-let handle_class_type_field self
- ({pctf_loc = loc } as ctf : Parsetree.class_type_field)
- acc =
- match ctf.pctf_desc with
- | Pctf_method
- (name, private_flag, virtual_flag, ty)
- ->
- let no (ty : Parsetree.core_type) =
- let ty =
- match ty.ptyp_desc with
- | Ptyp_arrow (label, args, body)
- ->
- Ast_util.to_method_type
- ty.ptyp_loc self label args body
- | Ptyp_poly (strs, {ptyp_desc = Ptyp_arrow (label, args, body);
- ptyp_loc})
- ->
- {ty with ptyp_desc =
- Ptyp_poly(strs,
- Ast_util.to_method_type
- ptyp_loc self label args body )}
- | _ ->
- self.typ self ty
- in
- {ctf with
- pctf_desc =
- Pctf_method (name , private_flag, virtual_flag, ty)}
- in
- let get ty name pctf_attributes =
- {ctf with
- pctf_desc =
- Pctf_method (name ,
- private_flag,
- virtual_flag,
- self.typ self ty
- );
- pctf_attributes} in
- let set ty name pctf_attributes =
- {ctf with
- pctf_desc =
- Pctf_method (name,
- private_flag,
- virtual_flag,
- Ast_util.to_method_type
- loc self "" ty
- (Ast_literal.type_unit ~loc ())
- );
- pctf_attributes} in
- process_getter_setter ~no ~get ~set loc name ctf.pctf_attributes ty acc
- | Pctf_inherit _
- | Pctf_val _
- | Pctf_constraint _
- | Pctf_attribute _
- | Pctf_extension _ ->
- Bs_ast_mapper.default_mapper.class_type_field self ctf :: acc
-(*
- Attributes are very hard to attribute
- (since ptyp_attributes could happen in so many places),
- and write ppx extensions correctly,
- we can only use it locally
-*)
+let record_as_js_object = ref false (* otherwise has an attribute *)
+let no_export = ref false
+
+let () =
+ Ast_derive_projector.init ();
+ Ast_derive_js_mapper.init ()
+
+let reset () =
+ record_as_js_object := false ;
+ no_export := false
+
+
+
+let newTdcls
+ (tdcls : Parsetree.type_declaration list)
+ (newAttrs : Parsetree.attributes) : Parsetree.type_declaration list =
+ match tdcls with
+ | [ x ] ->
+ [{ x with Parsetree.ptype_attributes = newAttrs}]
+ | _ ->
+ Ext_list.map_last
+ (fun last x ->
+ if last then { x with Parsetree.ptype_attributes = newAttrs} else x )
+ tdcls
+
-let handle_core_type
- (super : Bs_ast_mapper.mapper)
- (self : Bs_ast_mapper.mapper)
- (ty : Parsetree.core_type) =
- match ty with
- | {ptyp_desc = Ptyp_extension({txt = ("bs.obj"|"obj")}, PTyp ty)}
- ->
- Ext_ref.non_exn_protect record_as_js_object true
- (fun _ -> self.typ self ty )
- | {ptyp_attributes ;
- ptyp_desc = Ptyp_arrow (label, args, body);
- (* let it go without regard label names,
- it will report error later when the label is not empty
- *)
- ptyp_loc = loc
- } ->
- begin match Ast_attributes.process_attributes_rev ptyp_attributes with
- | `Uncurry , ptyp_attributes ->
- Ast_util.to_uncurry_type loc self label args body
- | `Meth_callback, ptyp_attributes ->
- Ast_util.to_method_callback_type loc self label args body
- | `Method, ptyp_attributes ->
- Ast_util.to_method_type loc self label args body
- | `Nothing , _ ->
- Bs_ast_mapper.default_mapper.typ self ty
- end
- | {
- ptyp_desc = Ptyp_object ( methods, closed_flag) ;
- ptyp_loc = loc
- } ->
- let (+>) attr (typ : Parsetree.core_type) =
- {typ with ptyp_attributes = attr :: typ.ptyp_attributes} in
- let new_methods =
- Ext_list.fold_right (fun (label, ptyp_attrs, core_type) acc ->
- let get ty name attrs =
- let attrs, core_type =
- match Ast_attributes.process_attributes_rev attrs with
- | `Nothing, attrs -> attrs, ty (* #1678 *)
- | `Uncurry, attrs ->
- attrs, Ast_attributes.bs +> ty
- | `Method, _
- -> Location.raise_errorf ~loc "bs.get/set conflicts with bs.meth"
- | `Meth_callback, attrs ->
- attrs, Ast_attributes.bs_this +> ty
- in
- name , attrs, self.typ self core_type in
- let set ty name attrs =
- let attrs, core_type =
- match Ast_attributes.process_attributes_rev attrs with
- | `Nothing, attrs -> attrs, ty
- | `Uncurry, attrs ->
- attrs, Ast_attributes.bs +> ty
- | `Method, _
- -> Location.raise_errorf ~loc "bs.get/set conflicts with bs.meth"
- | `Meth_callback, attrs ->
- attrs, Ast_attributes.bs_this +> ty
- in
- name, attrs, Ast_util.to_method_type loc self "" core_type
- (Ast_literal.type_unit ~loc ()) in
- let no ty =
- let attrs, core_type =
- match Ast_attributes.process_attributes_rev ptyp_attrs with
- | `Nothing, attrs -> attrs, ty
- | `Uncurry, attrs ->
- attrs, Ast_attributes.bs +> ty
- | `Method, attrs ->
- attrs, Ast_attributes.bs_method +> ty
- | `Meth_callback, attrs ->
- attrs, Ast_attributes.bs_this +> ty in
- label, attrs, self.typ self core_type in
- process_getter_setter ~no ~get ~set
- loc label ptyp_attrs core_type acc
- ) methods [] in
- let inner_type =
- { ty
- with ptyp_desc = Ptyp_object(new_methods, closed_flag);
- } in
- if !record_as_js_object then
- Ast_comb.to_js_type loc inner_type
- else inner_type
- | _ -> super.typ self ty
let rec unsafe_mapper : Bs_ast_mapper.mapper =
{ Bs_ast_mapper.default_mapper with
expr = (fun self ({ pexp_loc = loc } as e) ->
match e.pexp_desc with
(** Its output should not be rewritten anymore *)
- | Pexp_extension (
- {txt = ("bs.raw" | "raw"); loc} , payload)
- ->
- Ast_util.handle_raw loc payload
- | Pexp_extension (
- {txt = ("bs.re" | "re"); loc} , payload)
- ->
- Exp.constraint_ ~loc
- (Ast_util.handle_raw ~check_js_regex:true loc payload)
- (Ast_comb.to_js_re_type loc)
- | Pexp_extension ({txt = "bs.external" | "external" ; loc }, payload) ->
- begin match Ast_payload.as_ident payload with
- | Some {txt = Lident x}
- -> Ast_util.handle_external loc x
- (* do we need support [%external gg.xx ]
-
- {[ Js.Undefined.to_opt (if Js.typeof x == "undefined" then x else Js.Undefined.empty ) ]}
- *)
-
- | None | Some _ ->
- Location.raise_errorf ~loc
- "external expects a single identifier"
- end
- | Pexp_extension ({txt = "bs.time"| "time"; loc}, payload)
- ->
- (
- match payload with
- | PStr [{pstr_desc = Pstr_eval (e,_)}] ->
- let locString =
- if loc.loc_ghost then
- "GHOST LOC"
- else
- let loc_start = loc.loc_start in
- let (file, lnum, __) = Location.get_pos_info loc_start in
- Printf.sprintf "%s %d"
- file lnum in
- let e = self.expr self e in
- Exp.sequence ~loc
- (Exp.apply ~loc
- (Exp.ident ~loc {loc;
- txt =
- Ldot (Ldot (Lident "Js", "Console"), "timeStart")
- })
- ["", Exp.constant ~loc (Const_string (locString,None))]
- )
- ( Exp.let_ ~loc Nonrecursive
- [Vb.mk ~loc (Pat.var ~loc {loc; txt = "timed"}) e ;
- ]
- (Exp.sequence ~loc
- (Exp.apply ~loc
- (Exp.ident ~loc {loc;
- txt =
- Ldot (Ldot (Lident "Js", "Console"), "timeEnd")
- })
- ["", Exp.constant ~loc (Const_string (locString,None))]
- )
- (Exp.ident ~loc {loc; txt = Lident "timed"})
- )
- )
- | _ ->
- Location.raise_errorf
- ~loc "expect a boolean expression in the payload"
- )
- | Pexp_extension({txt = "bs.assert" | "assert";loc},payload)
- ->
- (
- match payload with
- | PStr [ {pstr_desc = Pstr_eval( e,_)}] ->
-
- let locString =
- if loc.loc_ghost then
- "ASSERT FAILURE"
- else
- let loc_start = loc.loc_start in
- let (file, lnum, cnum) = Location.get_pos_info loc_start in
- let enum =
- loc.Location.loc_end.Lexing.pos_cnum -
- loc_start.Lexing.pos_cnum + cnum in
- Printf.sprintf "File %S, line %d, characters %d-%d"
- file lnum cnum enum in
- let raiseWithString locString =
- (Exp.apply ~loc
- (Exp.ident ~loc {loc; txt =
- Ldot(Ldot (Lident "Js","Exn"),"raiseError")})
- ["",
-
- Exp.constant (Const_string (locString,None))
- ])
- in
- (match e.pexp_desc with
- | Pexp_construct({txt = Lident "false"},None) ->
- (* The backend will convert [assert false] into a nop later *)
- if !Clflags.no_assert_false then
- Exp.assert_ ~loc
- (Exp.construct ~loc {txt = Lident "false";loc} None)
- else
- (raiseWithString locString)
- | Pexp_constant (Const_string (r, _)) ->
- if !Clflags.noassert then
- Exp.assert_ ~loc (Exp.construct ~loc {txt = Lident "true"; loc} None)
- (* Need special handling to make it type check*)
- else
- raiseWithString r
- | _ ->
- let e = self.expr self e in
- if !Clflags.noassert then
- (* pass down so that it still type check, but the backend will
- make it a nop
- *)
- Exp.assert_ ~loc e
- else
- Exp.ifthenelse ~loc
- (Exp.apply ~loc
- (Exp.ident {loc ; txt = Ldot(Lident "Pervasives","not")})
- ["", e]
- )
- (raiseWithString locString)
- None
- )
- | _ ->
- Location.raise_errorf
- ~loc "expect a boolean expression in the payload"
- )
- (*
- [%%bs.import Bs_internalAVLSet.(a,b,c)]
- *)
- | Pexp_extension
- ({txt = ("bs.node" | "node"); loc},
- payload)
- ->
- let strip s =
- match s with
- | "_module" -> "module"
- | x -> x in
- begin match Ast_payload.as_ident payload with
- | Some {txt = Lident
- ( "__filename"
- | "__dirname"
- | "_module"
- | "require" as name); loc}
- ->
- let exp =
- Ast_util.handle_external loc (strip name) in
- let typ =
- Ast_core_type.lift_option_type
- @@
- if name = "_module" then
- Typ.constr ~loc
- { txt = Ldot (Lident "Node", "node_module") ;
- loc} []
- else if name = "require" then
- (Typ.constr ~loc
- { txt = Ldot (Lident "Node", "node_require") ;
- loc} [] )
- else
- Ast_literal.type_string ~loc () in
- Exp.constraint_ ~loc exp typ
- | Some _ | None ->
- begin match payload with
- | PTyp _ ->
- Location.raise_errorf
- ~loc "Illegal payload, expect an expression payload instead of type payload"
- | PPat _ ->
- Location.raise_errorf
- ~loc "Illegal payload, expect an expression payload instead of pattern payload"
- | _ ->
- Location.raise_errorf
- ~loc "Illegal payload"
- end
-
- end
- |Pexp_constant (Const_string (s, (Some delim)))
+ | Pexp_extension extension ->
+ Ast_exp_extension.handle_extension record_as_js_object e self extension
+ | Pexp_constant (Const_string (s, (Some delim)))
->
if Ext_string.equal delim Literals.unescaped_js_delimiter then
let js_str = Ast_utf8_string.transform loc s in
@@ -37144,27 +37547,11 @@ let rec unsafe_mapper : Bs_ast_mapper.mapper =
else if Ext_string.equal delim Literals.unescaped_j_delimiter then
Ast_utf8_string_interp.transform_interp loc s
else e
-
- (** [bs.debugger], its output should not be rewritten any more*)
- | Pexp_extension ({txt = ("bs.debugger"|"debugger"); loc} , payload)
- -> {e with pexp_desc = Ast_util.handle_debugger loc payload}
- | Pexp_extension ({txt = ("bs.obj" | "obj"); loc}, payload)
- ->
- begin match payload with
- | PStr [{pstr_desc = Pstr_eval (e,_)}]
- ->
- Ext_ref.non_exn_protect record_as_js_object true
- (fun () -> self.expr self e )
- | _ -> Location.raise_errorf ~loc "Expect an expression here"
- end
- | Pexp_extension({txt ; loc} as lid, PTyp typ)
- when Ext_string.starts_with txt Literals.bs_deriving_dot ->
- self.expr self @@
- Ast_derive.gen_expression lid typ
-
(** End rewriting *)
| Pexp_function cases ->
- begin match Ast_attributes.process_pexp_fun_attributes_rev e.pexp_attributes with
+ begin match
+ Ast_attributes.process_pexp_fun_attributes_rev e.pexp_attributes
+ with
| `Nothing, _ ->
Bs_ast_mapper.default_mapper.expr self e
| `Exn, pexp_attributes ->
@@ -37188,102 +37575,7 @@ let rec unsafe_mapper : Bs_ast_mapper.mapper =
pexp_attributes }
end
| Pexp_apply (fn, args ) ->
- begin match fn with
- | {pexp_desc =
- Pexp_apply (
- {pexp_desc =
- Pexp_ident {txt = Lident "##" ; loc} ; _},
- [("", obj) ;
- ("", {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _} )
- ]);
- _} -> (* f##paint 1 2 *)
- {e with pexp_desc = Ast_util.method_apply loc self obj name args }
- | {pexp_desc =
- Pexp_apply (
- {pexp_desc =
- Pexp_ident {txt = Lident "#@" ; loc} ; _},
- [("", obj) ;
- ("", {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _} )
- ]);
- _} -> (* f##paint 1 2 *)
- {e with pexp_desc = Ast_util.property_apply loc self obj name args }
-
- | {pexp_desc =
- Pexp_ident {txt = Lident "##" ; loc} ; _}
- ->
- begin match args with
- | [("", obj) ;
- ("", {pexp_desc = Pexp_apply(
- {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _},
- args
- ); pexp_attributes = attrs }
- (* we should warn when we discard attributes *)
- )
- ] -> (* f##(paint 1 2 ) *)
- (* gpr#1063 foo##(bar##baz) we should rewrite (bar##baz)
- first before pattern match.
- currently the pattern match is written in a top down style.
- Another corner case: f##(g a b [@bs])
- *)
- Bs_ast_invariant.warn_unused_attributes attrs ;
- {e with pexp_desc = Ast_util.method_apply loc self obj name args}
- | [("", obj) ;
- ("",
- {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _}
- ) (* f##paint *)
- ] ->
- { e with pexp_desc =
- Ast_util.js_property loc (self.expr self obj) name
- }
-
- | _ ->
- Location.raise_errorf ~loc
- "Js object ## expect syntax like obj##(paint (a,b)) "
- end
- (* we can not use [:=] for precedece cases
- like {[i @@ x##length := 3 ]}
- is parsed as {[ (i @@ x##length) := 3]}
- since we allow user to create Js objects in OCaml, it can be of
- ref type
- {[
- let u = object (self)
- val x = ref 3
- method setX x = self##x := 32
- method getX () = !self##x
- end
- ]}
- *)
- | {pexp_desc =
- Pexp_ident {txt = Lident ("#=" )}
- } ->
- begin match args with
- | ["",
- {pexp_desc =
- Pexp_apply ({pexp_desc = Pexp_ident {txt = Lident "##"}},
- ["", obj;
- "", {pexp_desc = Pexp_ident {txt = Lident name}}
- ]
- )};
- "", arg
- ] ->
- Exp.constraint_ ~loc
- { e with
- pexp_desc =
- Ast_util.method_apply loc self obj
- (name ^ Literals.setter_suffix) ["", arg ] }
- (Ast_literal.type_unit ~loc ())
- | _ -> Bs_ast_mapper.default_mapper.expr self e
- end
- | _ ->
- begin match
- Ext_list.exclude_with_val
- Ast_attributes.is_bs e.pexp_attributes with
- | false, _ -> Bs_ast_mapper.default_mapper.expr self e
- | true, pexp_attributes ->
- {e with pexp_desc = Ast_util.uncurry_fn_apply loc self fn args ;
- pexp_attributes }
- end
- end
+ Ast_exp_apply.handle_exp_apply e self fn args
| Pexp_record (label_exprs, opt_exp) ->
if !record_as_js_object then
(match opt_exp with
@@ -37319,7 +37611,8 @@ let rec unsafe_mapper : Bs_ast_mapper.mapper =
end
| _ -> Bs_ast_mapper.default_mapper.expr self e
);
- typ = (fun self typ -> handle_core_type Bs_ast_mapper.default_mapper self typ);
+ typ = (fun self typ ->
+ Ast_core_type_class_type.handle_core_type self typ record_as_js_object);
class_type =
(fun self ({pcty_attributes; pcty_loc} as ctd) ->
match Ast_attributes.process_bs pcty_attributes with
@@ -37334,7 +37627,7 @@ let rec unsafe_mapper : Bs_ast_mapper.mapper =
{ctd with
pcty_desc = Pcty_signature {
pcsig_self ;
- pcsig_fields = Ext_list.fold_right (handle_class_type_field self) pcsig_fields []
+ pcsig_fields = Ast_core_type_class_type.handle_class_type_fields self pcsig_fields
};
pcty_attributes
}
@@ -37432,12 +37725,7 @@ let rec unsafe_mapper : Bs_ast_mapper.mapper =
| _ -> Bs_ast_mapper.default_mapper.pat self pat
end;
- value_bindings = begin fun self (vbs : Parsetree.value_binding list) ->
- (* Bs_ast_mapper.default_mapper.value_bindings self vbs *)
- List.fold_right (fun vb acc ->
- flattern_tuple_pattern_vb self vb acc
- ) vbs []
- end;
+ value_bindings = Ast_tuple_pattern_flatten.handle_value_bindings;
structure_item = begin fun self (str : Parsetree.structure_item) ->
begin match str.pstr_desc with
| Pstr_extension ( ({txt = ("bs.raw"| "raw") ; loc}, payload), _attrs)
diff --git a/lib/bsppx.d b/lib/bsppx.d
index 567b91dacb..099c62b328 100644
--- a/lib/bsppx.d
+++ b/lib/bsppx.d
@@ -68,6 +68,7 @@
../lib/bsppx.ml : ./common/lam_methname.mli
../lib/bsppx.ml : ./ext/string_hash_set.mli
../lib/bsppx.ml : ./syntax/ast_core_type.ml
+../lib/bsppx.ml : ./syntax/ast_exp_apply.ml
../lib/bsppx.ml : ./syntax/ast_signature.ml
../lib/bsppx.ml : ./syntax/ast_structure.ml
../lib/bsppx.ml : ./syntax/bs_ast_mapper.ml
@@ -77,6 +78,7 @@
../lib/bsppx.ml : ../vendor/ocaml/utils/warnings.ml
../lib/bsppx.ml : ./syntax/ast_attributes.ml
../lib/bsppx.ml : ./syntax/ast_core_type.mli
+../lib/bsppx.ml : ./syntax/ast_exp_apply.mli
../lib/bsppx.ml : ./syntax/ast_signature.mli
../lib/bsppx.ml : ./syntax/ast_structure.mli
../lib/bsppx.ml : ./syntax/bs_ast_mapper.mli
@@ -97,6 +99,7 @@
../lib/bsppx.ml : ../vendor/ocaml/parsing/asttypes.mli
../lib/bsppx.ml : ../vendor/ocaml/parsing/location.mli
../lib/bsppx.ml : ../vendor/ocaml/parsing/longident.ml
+../lib/bsppx.ml : ./syntax/ast_exp_extension.ml
../lib/bsppx.ml : ./syntax/bs_ast_invariant.mli
../lib/bsppx.ml : ./syntax/external_arg_spec.ml
../lib/bsppx.ml : ./syntax/external_process.mli
@@ -104,6 +107,7 @@
../lib/bsppx.ml : ../vendor/ocaml/parsing/docstrings.ml
../lib/bsppx.ml : ../vendor/ocaml/parsing/longident.mli
../lib/bsppx.ml : ../vendor/ocaml/parsing/parsetree.mli
+../lib/bsppx.ml : ./syntax/ast_exp_extension.mli
../lib/bsppx.ml : ./syntax/external_arg_spec.mli
../lib/bsppx.ml : ./syntax/external_ffi_types.ml
../lib/bsppx.ml : ../vendor/ocaml/parsing/ast_helper.mli
@@ -119,3 +123,7 @@
../lib/bsppx.ml : ./syntax/ast_derive_projector.mli
../lib/bsppx.ml : ./syntax/ast_utf8_string_interp.ml
../lib/bsppx.ml : ./syntax/ast_utf8_string_interp.mli
+../lib/bsppx.ml : ./syntax/ast_core_type_class_type.ml
+../lib/bsppx.ml : ./syntax/ast_core_type_class_type.mli
+../lib/bsppx.ml : ./syntax/ast_tuple_pattern_flatten.ml
+../lib/bsppx.ml : ./syntax/ast_tuple_pattern_flatten.mli
diff --git a/lib/bsppx.ml b/lib/bsppx.ml
index ffc044c2f4..c24b5edffe 100644
--- a/lib/bsppx.ml
+++ b/lib/bsppx.ml
@@ -10559,8 +10559,8 @@ let bs_set : attr
end
-module Ast_signature : sig
-#1 "ast_signature.mli"
+module Ast_exp : sig
+#1 "ast_exp.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -10585,13 +10585,10 @@ module Ast_signature : sig
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-type item = Parsetree.signature_item
-type t = item list
-
+type t = Parsetree.expression
-val fuseAll : ?loc:Ast_helper.loc -> t -> item
end = struct
-#1 "ast_signature.ml"
+#1 "ast_exp.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -10616,17 +10613,11 @@ end = struct
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-type item = Parsetree.signature_item
-type t = item list
-
-open Ast_helper
+type t = Parsetree.expression
-let fuseAll ?(loc=Location.none) (t : t) : item =
- Sig.include_ ~loc (Incl.mk ~loc (Mty.signature ~loc t))
-
end
-module Ast_structure : sig
-#1 "ast_structure.mli"
+module Ast_external_mk : sig
+#1 "ast_external_mk.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -10651,25 +10642,35 @@ module Ast_structure : sig
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
+(**
+ [local_module loc ~pval_prim ~pval_type args]
+ generate such code
+ {[
+ let module J = struct
+ external unsafe_expr : pval_type = pval_prim
+ end in
+ J.unssafe_expr args
+ ]}
+*)
+val local_external : Location.t ->
+ ?pval_attributes:Parsetree.attributes ->
+ pval_prim:string list ->
+ pval_type:Parsetree.core_type ->
+ ?local_module_name:string ->
+ ?local_fun_name:string ->
+ (string * Parsetree.expression) list -> Parsetree.expression_desc
-type item = Parsetree.structure_item
-
-type t = item list
-
-
-val fuseAll: ?loc:Ast_helper.loc -> t -> item
-
-(* val fuse_with_constraint:
- ?loc:Ast_helper.loc ->
- Parsetree.type_declaration list ->
- t ->
- Ast_signature.t ->
- item *)
-
-val constraint_ : ?loc:Ast_helper.loc -> t -> Ast_signature.t -> item
+val local_extern_cont :
+ Location.t ->
+ ?pval_attributes:Parsetree.attributes ->
+ pval_prim:string list ->
+ pval_type:Parsetree.core_type ->
+ ?local_module_name:string ->
+ ?local_fun_name:string ->
+ (Parsetree.expression -> Parsetree.expression) -> Parsetree.expression_desc
end = struct
-#1 "ast_structure.ml"
+#1 "ast_external_mk.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -10694,39 +10695,73 @@ end = struct
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-type item = Parsetree.structure_item
-
-type t = item list
-
-open Ast_helper
-
+let 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_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 fuseAll ?(loc=Location.none) (t : t) : item =
- Str.include_ ~loc
- (Incl.mk ~loc (Mod.structure ~loc t ))
-
-(* let fuse_with_constraint
- ?(loc=Location.none)
- (item : Parsetree.type_declaration list ) (t : t) (coercion) =
- Str.include_ ~loc
- (Incl.mk ~loc
- (Mod.constraint_
- (Mod.structure ~loc
- ({pstr_loc = loc; pstr_desc = Pstr_type item} :: t) )
- (
- Mty.signature ~loc
- ({psig_loc = loc; psig_desc = Psig_type item} :: coercion)
- )
- )
- ) *)
-let constraint_ ?(loc=Location.none) (stru : t) (sign : Ast_signature.t) =
- Str.include_ ~loc
- (Incl.mk ~loc
- (Mod.constraint_ ~loc (Mod.structure ~loc stru) (Mty.signature ~loc sign)))
+let local_extern_cont loc
+ ?(pval_attributes=[])
+ ~pval_prim
+ ~pval_type
+ ?(local_module_name = "J")
+ ?(local_fun_name = "unsafe_expr")
+ (cb : Parsetree.expression -> 'a)
+ : 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_attributes };
+ pstr_loc = loc;
+ }];
+ pmod_loc = loc;
+ pmod_attributes = []},
+ cb {pexp_desc = Pexp_ident {txt = Ldot (Lident local_module_name, local_fun_name);
+ loc};
+ pexp_attributes = [] ;
+ pexp_loc = loc}
+)
end
-module Ast_derive : sig
-#1 "ast_derive.mli"
+module Ast_pat : sig
+#1 "ast_pat.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -10751,51 +10786,19 @@ module Ast_derive : sig
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-type tdcls = Parsetree.type_declaration list
-
-type gen = {
- structure_gen : tdcls -> bool -> Ast_structure.t ;
- signature_gen : tdcls -> bool -> Ast_signature.t ;
- expression_gen : (Parsetree.core_type -> Parsetree.expression) option ;
-}
-
-(**
- [register name cb]
- example: [register "accessors" cb]
-*)
-val register :
- string ->
- (Parsetree.expression option -> gen) ->
- unit
-
-(* val gen_structure:
- tdcls ->
- Ast_payload.action list ->
- bool ->
- Ast_structure.t *)
-
-val gen_signature:
- tdcls ->
- Ast_payload.action list ->
- bool ->
- Ast_signature.t
+type t = Parsetree.pattern
+val is_unit_cont : yes:'a -> no:'a -> t -> 'a
-val gen_expression :
- string Asttypes.loc ->
- Parsetree.core_type ->
- Parsetree.expression
+(** [arity_of_fun pat e] tells the arity of
+ expression [fun pat -> e]*)
+val arity_of_fun : t -> Parsetree.expression -> int
+val is_single_variable_pattern_conservative : t -> bool
-val gen_structure_signature :
- Location.t ->
- Parsetree.type_declaration list ->
- Ast_payload.action ->
- bool ->
- Parsetree.structure_item
end = struct
-#1 "ast_derive.ml"
+#1 "ast_pat.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -10820,512 +10823,921 @@ end = struct
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-type tdcls = Parsetree.type_declaration list
-
-type gen = {
- structure_gen : tdcls -> bool -> Ast_structure.t ;
- signature_gen : tdcls -> bool -> Ast_signature.t ;
- expression_gen : (Parsetree.core_type -> Parsetree.expression) option ;
-}
-(* the first argument is [config] payload
- {[
- { x = {uu} }
- ]}
-*)
-type derive_table =
- (Parsetree.expression option -> gen) String_map.t
+type t = Parsetree.pattern
-let derive_table : derive_table ref = ref String_map.empty
-let register key value =
- derive_table := String_map.add key value !derive_table
+let is_unit_cont ~yes ~no (p : t) =
+ match p with
+ | {ppat_desc = Ppat_construct({txt = Lident "()"}, None)}
+ -> yes
+ | _ -> no
+(** [arity_of_fun pat e] tells the arity of
+ expression [fun pat -> e]
+*)
+let arity_of_fun
+ (pat : Parsetree.pattern)
+ (e : Parsetree.expression) =
+ let rec aux (e : Parsetree.expression) =
+ match e.pexp_desc with
+ | Pexp_fun ("", None, pat, e) ->
+ 1 + aux e
+ | Pexp_fun _
+ -> Location.raise_errorf
+ ~loc:e.pexp_loc "Label is not allowed in JS object"
+ | _ -> 0 in
+ is_unit_cont ~yes:0 ~no:1 pat + aux e
-(* let gen_structure
- (tdcls : tdcls)
- (actions : Ast_payload.action list )
- (explict_nonrec : bool )
- : Ast_structure.t =
- Ext_list.flat_map
- (fun action ->
- (Ast_payload.table_dispatch !derive_table action).structure_gen
- tdcls explict_nonrec) actions *)
-let gen_signature
- tdcls
- (actions : Ast_payload.action list )
- (explict_nonrec : bool )
- : Ast_signature.t =
- Ext_list.flat_map
- (fun action ->
- (Ast_payload.table_dispatch !derive_table action).signature_gen
- tdcls explict_nonrec) actions
+let rec is_single_variable_pattern_conservative (p : t ) =
+ match p.ppat_desc with
+ | Parsetree.Ppat_any
+ | Parsetree.Ppat_var _ -> true
+ | Parsetree.Ppat_alias (p,_)
+ | Parsetree.Ppat_constraint (p, _) ->
+ is_single_variable_pattern_conservative p
+
+ | _ -> false
-(** used for cases like [%sexp] *)
-let gen_expression ({Asttypes.txt ; loc}) typ =
- let txt = Ext_string.tail_from txt (String.length Literals.bs_deriving_dot) in
- match (Ast_payload.table_dispatch !derive_table
- ({txt ; loc}, None)).expression_gen with
- | None ->
- Bs_syntaxerr.err loc (Unregistered txt)
+end
+module Bs_ast_mapper : sig
+#1 "bs_ast_mapper.mli"
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
- | Some f -> f typ
+(** The interface of a -ppx rewriter
-open Ast_helper
-let gen_structure_signature
- loc
- (tdcls : tdcls)
- (action : Ast_payload.action)
- (explicit_nonrec : bool) =
- let derive_table = !derive_table in
- let u =
- Ast_payload.table_dispatch derive_table action in
+ A -ppx rewriter is a program that accepts a serialized abstract syntax
+ tree and outputs another, possibly modified, abstract syntax tree.
+ This module encapsulates the interface between the compiler and
+ the -ppx rewriters, handling such details as the serialization format,
+ forwarding of command-line flags, and storing state.
- let a = u.structure_gen tdcls explicit_nonrec in
- let b = u.signature_gen tdcls explicit_nonrec in
- Str.include_ ~loc
- (Incl.mk ~loc
- (Mod.constraint_ ~loc
- (Mod.structure ~loc a)
- (Mty.signature ~loc b )
- )
- )
-end
-module Ast_derive_util : sig
-#1 "ast_derive_util.mli"
-(* Copyright (C) 2017 Authors of BuckleScript
- *
- * 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. *)
+ {!mapper} allows to implement AST rewriting using open recursion.
+ A typical mapper would be based on {!default_mapper}, a deep
+ identity mapper, and will fall back on it for handling the syntax it
+ does not modify. For example:
-(** Given a type declaration, extaract the type expression, mostly
- used in code gen later
- *)
- val core_type_of_type_declaration :
- Parsetree.type_declaration -> Parsetree.core_type
+ {[
+open Asttypes
+open Parsetree
+open Ast_mapper
-val new_type_of_type_declaration :
- Parsetree.type_declaration ->
- string ->
- Parsetree.core_type * Parsetree.type_declaration
+let test_mapper argv =
+ { default_mapper with
+ expr = fun mapper expr ->
+ match expr with
+ | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} ->
+ Ast_helper.Exp.constant (Const_int 42)
+ | other -> default_mapper.expr mapper other; }
-val lift_string_list_to_array : string list -> Parsetree.expression
-val lift_int : int -> Parsetree.expression
-val lift_int_list_to_array : int list -> Parsetree.expression
-val mk_fun :
- loc:Location.t ->
- Parsetree.core_type ->
- string -> Parsetree.expression -> Parsetree.expression
-val destruct_label_declarations :
- loc:Location.t ->
- string ->
- Parsetree.label_declaration list ->
- (Parsetree.core_type * Parsetree.expression) list * string list
+let () =
+ register "ppx_test" test_mapper]}
-val notApplicable:
- Location.t ->
- string ->
- unit
+ This -ppx rewriter, which replaces [[%test]] in expressions with
+ the constant [42], can be compiled using
+ [ocamlc -o ppx_test -I +compiler-libs ocamlcommon.cma ppx_test.ml].
-val invalid_config : Parsetree.expression -> 'a
+ *)
+
+ open Parsetree
+
+ (** {2 A generic Parsetree mapper} *)
+
+ type mapper = {
+ attribute: mapper -> attribute -> attribute;
+ attributes: mapper -> attribute list -> attribute list;
+ case: mapper -> case -> case;
+ cases: mapper -> case list -> case list;
+ class_declaration: mapper -> class_declaration -> class_declaration;
+ class_description: mapper -> class_description -> class_description;
+ class_expr: mapper -> class_expr -> class_expr;
+ class_field: mapper -> class_field -> class_field;
+ class_signature: mapper -> class_signature -> class_signature;
+ class_structure: mapper -> class_structure -> class_structure;
+ class_type: mapper -> class_type -> class_type;
+ class_type_declaration: mapper -> class_type_declaration
+ -> class_type_declaration;
+ class_type_field: mapper -> class_type_field -> class_type_field;
+ constructor_declaration: mapper -> constructor_declaration
+ -> constructor_declaration;
+ expr: mapper -> expression -> expression;
+ extension: mapper -> extension -> extension;
+ extension_constructor: mapper -> extension_constructor
+ -> extension_constructor;
+ include_declaration: mapper -> include_declaration -> include_declaration;
+ include_description: mapper -> include_description -> include_description;
+ label_declaration: mapper -> label_declaration -> label_declaration;
+ location: mapper -> Location.t -> Location.t;
+ module_binding: mapper -> module_binding -> module_binding;
+ module_declaration: mapper -> module_declaration -> module_declaration;
+ module_expr: mapper -> module_expr -> module_expr;
+ module_type: mapper -> module_type -> module_type;
+ module_type_declaration: mapper -> module_type_declaration
+ -> module_type_declaration;
+ open_description: mapper -> open_description -> open_description;
+ pat: mapper -> pattern -> pattern;
+ payload: mapper -> payload -> payload;
+ signature: mapper -> signature -> signature;
+ signature_item: mapper -> signature_item -> signature_item;
+ structure: mapper -> structure -> structure;
+ structure_item: mapper -> structure_item -> structure_item;
+ typ: mapper -> core_type -> core_type;
+ type_declaration: mapper -> type_declaration -> type_declaration;
+ type_extension: mapper -> type_extension -> type_extension;
+ type_kind: mapper -> type_kind -> type_kind;
+ value_binding: mapper -> value_binding -> value_binding;
+(* XXXXX *)
+ value_bindings_rec: mapper -> value_binding list -> value_binding list;
+ value_bindings: mapper -> value_binding list -> value_binding list;
+(* XXXXX *)
+ value_description: mapper -> value_description -> value_description;
+ with_constraint: mapper -> with_constraint -> with_constraint;
+ }
+ (** A mapper record implements one "method" per syntactic category,
+ using an open recursion style: each method takes as its first
+ argument the mapper to be applied to children in the syntax
+ tree. *)
+
+ val default_mapper: mapper
+ (** A default mapper, which implements a "deep identity" mapping. *)
+
end = struct
-#1 "ast_derive_util.ml"
-(* 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. *)
+#1 "bs_ast_mapper.ml"
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
-open Ast_helper
+(* A generic Parsetree mapping class *)
+(* Adapted for BUcklescript with more flexibilty*)
-let core_type_of_type_declaration
- (tdcl : Parsetree.type_declaration) =
- match tdcl with
- | {ptype_name = {txt ; loc};
- ptype_params ;
- } ->
- Typ.constr
- {txt = Lident txt ; loc}
- (Ext_list.map fst ptype_params)
+[@@@ocaml.warning "+9"]
+(* Ensure that record patterns don't miss any field. *)
-let new_type_of_type_declaration
- (tdcl : Parsetree.type_declaration) newName =
- match tdcl with
- | {ptype_name = { loc};
- ptype_params ;
- } ->
- (Typ.constr
- {txt = Lident newName ; loc}
- (Ext_list.map fst ptype_params),
- { Parsetree.ptype_params = tdcl.ptype_params;
- ptype_name = {txt = newName;loc};
- ptype_kind = Ptype_abstract;
- ptype_attributes = [];
- ptype_loc = tdcl.ptype_loc;
- ptype_cstrs = []; ptype_private = Public; ptype_manifest = None}
- )
-
-let lift_string_list_to_array (labels : string list) =
- Exp.array
- (Ext_list.map (fun s -> Exp.constant (Const_string (s, None)))
- labels)
-let lift_int i = Exp.constant (Const_int i)
-let lift_int_list_to_array (labels : int list) =
- Exp.array (Ext_list.map lift_int labels)
+open Asttypes
+open Parsetree
+open Ast_helper
+open Location
+type mapper = {
+ attribute: mapper -> attribute -> attribute;
+ attributes: mapper -> attribute list -> attribute list;
+ case: mapper -> case -> case;
+ cases: mapper -> case list -> case list;
+ class_declaration: mapper -> class_declaration -> class_declaration;
+ class_description: mapper -> class_description -> class_description;
+ class_expr: mapper -> class_expr -> class_expr;
+ class_field: mapper -> class_field -> class_field;
+ class_signature: mapper -> class_signature -> class_signature;
+ class_structure: mapper -> class_structure -> class_structure;
+ class_type: mapper -> class_type -> class_type;
+ class_type_declaration: mapper -> class_type_declaration
+ -> class_type_declaration;
+ class_type_field: mapper -> class_type_field -> class_type_field;
+ constructor_declaration: mapper -> constructor_declaration
+ -> constructor_declaration;
+ expr: mapper -> expression -> expression;
+ extension: mapper -> extension -> extension;
+ extension_constructor: mapper -> extension_constructor
+ -> extension_constructor;
+ include_declaration: mapper -> include_declaration -> include_declaration;
+ include_description: mapper -> include_description -> include_description;
+ label_declaration: mapper -> label_declaration -> label_declaration;
+ location: mapper -> Location.t -> Location.t;
+ module_binding: mapper -> module_binding -> module_binding;
+ module_declaration: mapper -> module_declaration -> module_declaration;
+ module_expr: mapper -> module_expr -> module_expr;
+ module_type: mapper -> module_type -> module_type;
+ module_type_declaration: mapper -> module_type_declaration
+ -> module_type_declaration;
+ open_description: mapper -> open_description -> open_description;
+ pat: mapper -> pattern -> pattern;
+ payload: mapper -> payload -> payload;
+ signature: mapper -> signature -> signature;
+ signature_item: mapper -> signature_item -> signature_item;
+ structure: mapper -> structure -> structure;
+ structure_item: mapper -> structure_item -> structure_item;
+ typ: mapper -> core_type -> core_type;
+ type_declaration: mapper -> type_declaration -> type_declaration;
+ type_extension: mapper -> type_extension -> type_extension;
+ type_kind: mapper -> type_kind -> type_kind;
+ value_binding: mapper -> value_binding -> value_binding;
+(* XXXX *)
+ value_bindings_rec : mapper -> value_binding list -> value_binding list;
+ value_bindings : mapper -> value_binding list -> value_binding list;
+(* XXXXX *)
+ value_description: mapper -> value_description -> value_description;
+ with_constraint: mapper -> with_constraint -> with_constraint;
+}
-let mk_fun ~loc (typ : Parsetree.core_type)
- (value : string) body
- : Parsetree.expression =
- Exp.fun_
- "" None
- (Pat.constraint_ (Pat.var {txt = value ; loc}) typ)
- body
+let map_fst f (x, y) = (f x, y)
+let map_snd f (x, y) = (x, f y)
+let map_tuple f1 f2 (x, y) = (f1 x, f2 y)
+let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
+let map_opt f = function None -> None | Some x -> Some (f x)
-let destruct_label_declarations ~loc
- (arg_name : string)
- (labels : Parsetree.label_declaration list) :
- (Parsetree.core_type * Parsetree.expression) list * string list
- =
- Ext_list.fold_right
- (fun ({pld_name = {txt}; pld_type} : Parsetree.label_declaration)
- (core_type_exps, labels) ->
- ((pld_type,
- Exp.field (Exp.ident {txt = Lident arg_name ; loc})
- {txt = Lident txt ; loc}) :: core_type_exps),
- txt :: labels
- ) labels ([], [])
+let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt}
-let notApplicable
- loc derivingName =
- Location.prerr_warning
- loc
- (Warnings.Bs_derive_warning ( derivingName ^ " not applicable to this type"))
-
-let invalid_config (config : Parsetree.expression) =
- Location.raise_errorf ~loc:config.pexp_loc "such configuration is not supported"
-
-end
-module Ast_derive_abstract : sig
-#1 "ast_derive_abstract.mli"
-(* Copyright (C) 2017 Authors of BuckleScript
- *
- * 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 T = struct
+ (* Type expressions for the core language *)
-val handleTdclsInStr :
- Parsetree.type_declaration list -> Parsetree.structure
+ let row_field sub = function
+ | Rtag (l, attrs, b, tl) ->
+ Rtag (l, sub.attributes sub attrs, b, List.map (sub.typ sub) tl)
+ | Rinherit t -> Rinherit (sub.typ sub t)
-val handleTdclsInSig:
- Parsetree.type_declaration list -> Parsetree.signature
-end = struct
-#1 "ast_derive_abstract.ml"
-(* Copyright (C) 2017 Authors of BuckleScript
- *
- * 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 map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} =
+ let open Typ in
+ let loc = sub.location sub loc in
+ let attrs = sub.attributes sub attrs in
+ match desc with
+ | Ptyp_any -> any ~loc ~attrs ()
+ | Ptyp_var s -> var ~loc ~attrs s
+ | Ptyp_arrow (lab, t1, t2) ->
+ arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2)
+ | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl)
+ | Ptyp_constr (lid, tl) ->
+ constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
+ | Ptyp_object (l, o) ->
+ let f (s, a, t) = (s, sub.attributes sub a, sub.typ sub t) in
+ object_ ~loc ~attrs (List.map f l) o
+ | Ptyp_class (lid, tl) ->
+ class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
+ | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s
+ | Ptyp_variant (rl, b, ll) ->
+ variant ~loc ~attrs (List.map (row_field sub) rl) b ll
+ | Ptyp_poly (sl, t) -> poly ~loc ~attrs sl (sub.typ sub t)
+ | Ptyp_package (lid, l) ->
+ package ~loc ~attrs (map_loc sub lid)
+ (List.map (map_tuple (map_loc sub) (sub.typ sub)) l)
+ | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x)
+ let map_type_declaration sub
+ {ptype_name; ptype_params; ptype_cstrs;
+ ptype_kind;
+ ptype_private;
+ ptype_manifest;
+ ptype_attributes;
+ ptype_loc} =
+ Type.mk (map_loc sub ptype_name)
+ ~params:(List.map (map_fst (sub.typ sub)) ptype_params)
+ ~priv:ptype_private
+ ~cstrs:(List.map
+ (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub))
+ ptype_cstrs)
+ ~kind:(sub.type_kind sub ptype_kind)
+ ?manifest:(map_opt (sub.typ sub) ptype_manifest)
+ ~loc:(sub.location sub ptype_loc)
+ ~attrs:(sub.attributes sub ptype_attributes)
-let derivingName = "abstract"
-module U = Ast_derive_util
-open Ast_helper
-type tdcls = Parsetree.type_declaration list
+ let map_type_kind sub = function
+ | Ptype_abstract -> Ptype_abstract
+ | Ptype_variant l ->
+ Ptype_variant (List.map (sub.constructor_declaration sub) l)
+ | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l)
+ | Ptype_open -> Ptype_open
-let handle_config (config : Parsetree.expression option) =
- match config with
- | Some config ->
- U.invalid_config config
- | None -> ()
+ let map_type_extension sub
+ {ptyext_path; ptyext_params;
+ ptyext_constructors;
+ ptyext_private;
+ ptyext_attributes} =
+ Te.mk
+ (map_loc sub ptyext_path)
+ (List.map (sub.extension_constructor sub) ptyext_constructors)
+ ~params:(List.map (map_fst (sub.typ sub)) ptyext_params)
+ ~priv:ptyext_private
+ ~attrs:(sub.attributes sub ptyext_attributes)
-(* see #2337
- TODO: relax it to allow (int -> int [@bs])
-*)
-let rec checkNotFunciton (ty : Parsetree.core_type) =
- match ty.ptyp_desc with
- | Ptyp_poly (_,ty) -> checkNotFunciton ty
- | Ptyp_alias (ty,_) -> checkNotFunciton ty
- | Ptyp_arrow _ ->
- Location.raise_errorf
- ~loc:ty.ptyp_loc
- "syntactic function type is not allowed when working with abstract bs.deriving, create a named type as work around"
- | Ptyp_any
- | Ptyp_var _
- | Ptyp_tuple _
- | Ptyp_constr _
- | Ptyp_object _
- | Ptyp_class _
- | Ptyp_variant _
- | Ptyp_package _
- | Ptyp_extension _ -> ()
-let handleTdcl (tdcl : Parsetree.type_declaration) =
- let core_type = U.core_type_of_type_declaration tdcl in
- let loc = tdcl.ptype_loc in
- let name = tdcl.ptype_name.txt in
- let newTdcl = {
- tdcl with
- ptype_kind = Ptype_abstract;
- ptype_attributes = [];
- (* avoid non-terminating*)
- } in
- match tdcl.ptype_kind with
- | Ptype_record label_declarations ->
- let ty =
- Ext_list.fold_right (fun (label_declaration : Parsetree.label_declaration) acc ->
- Typ.arrow
- label_declaration.pld_name.txt label_declaration.pld_type acc
- ) label_declarations core_type in
- let setter_accessor =
- Ext_list.fold_right (fun (x: Parsetree.label_declaration) acc ->
- let pld_name = x.pld_name.txt in
- let pld_loc = x.pld_name.loc in
- let pld_type = x.pld_type in
- let () = checkNotFunciton pld_type in
- let setter =
- Val.mk
- {loc = pld_loc; txt = pld_name}
- ~attrs:[Ast_attributes.bs_get]
- ~prim:[pld_name]
- (Typ.arrow "" core_type pld_type) :: acc in
- match x.pld_mutable with
- | Mutable ->
- Val.mk
- {loc = pld_loc; txt = pld_name ^ "Set"}
- ~attrs:[Ast_attributes.bs_set]
- ~prim:[pld_name]
- (Typ.arrow "" core_type (Typ.arrow "" pld_type (Ast_literal.type_unit ()))) :: setter
- | Immutable -> setter
- ) label_declarations []
- in
-
- newTdcl,
- (match tdcl.ptype_private with
- | Private -> setter_accessor
- | Public ->
- let maker =
- Val.mk {loc; txt = name}
- ~attrs:[Ast_attributes.bs_obj]
- ~prim:[""] ty in
- (maker :: setter_accessor))
-
- | Ptype_abstract
- | Ptype_variant _
- | Ptype_open ->
- (* Looks obvious that it does not make sense to warn *)
- (* U.notApplicable tdcl.ptype_loc derivingName; *)
- tdcl, []
-
-let handleTdclsInStr tdcls =
- let tdcls, code =
- List.fold_right (fun tdcl (tdcls, sts) ->
- match handleTdcl tdcl with
- ntdcl, value_descriptions ->
- ntdcl::tdcls,
- Ext_list.map_append (fun x -> Str.primitive x) value_descriptions sts
-
- ) tdcls ([],[]) in
- Str.type_ tdcls :: code
-(* still need perform transformation for non-abstract type*)
+ let map_extension_constructor_kind sub = function
+ Pext_decl(ctl, cto) ->
+ Pext_decl(List.map (sub.typ sub) ctl, map_opt (sub.typ sub) cto)
+ | Pext_rebind li ->
+ Pext_rebind (map_loc sub li)
-let handleTdclsInSig tdcls =
- let tdcls, code =
- List.fold_right (fun tdcl (tdcls, sts) ->
- match handleTdcl tdcl with
- ntdcl, value_descriptions ->
- ntdcl::tdcls,
- Ext_list.map_append (fun x -> Sig.value x) value_descriptions sts
+ let map_extension_constructor sub
+ {pext_name;
+ pext_kind;
+ pext_loc;
+ pext_attributes} =
+ Te.constructor
+ (map_loc sub pext_name)
+ (map_extension_constructor_kind sub pext_kind)
+ ~loc:(sub.location sub pext_loc)
+ ~attrs:(sub.attributes sub pext_attributes)
- ) tdcls ([],[]) in
- Sig.type_ tdcls :: code
end
-module Ext_pervasives : sig
-#1 "ext_pervasives.mli"
-(* 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 CT = struct
+ (* Type expressions for the class language *)
+ let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} =
+ let open Cty in
+ let loc = sub.location sub loc in
+ let attrs = sub.attributes sub attrs in
+ match desc with
+ | Pcty_constr (lid, tys) ->
+ constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys)
+ | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x)
+ | Pcty_arrow (lab, t, ct) ->
+ arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct)
+ | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x)
+ let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs}
+ =
+ let open Ctf in
+ let loc = sub.location sub loc in
+ let attrs = sub.attributes sub attrs in
+ match desc with
+ | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct)
+ | Pctf_val (s, m, v, t) -> val_ ~loc ~attrs s m v (sub.typ sub t)
+ | Pctf_method (s, p, v, t) -> method_ ~loc ~attrs s p v (sub.typ sub t)
+ | Pctf_constraint (t1, t2) ->
+ constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2)
+ | Pctf_attribute x -> attribute ~loc (sub.attribute sub x)
+ | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x)
+ let map_signature sub {pcsig_self; pcsig_fields} =
+ Csig.mk
+ (sub.typ sub pcsig_self)
+ (List.map (sub.class_type_field sub) pcsig_fields)
+end
-(** Extension to standard library [Pervavives] module, safe to open
- *)
+module MT = struct
+ (* Type expressions for the module language *)
-external reraise: exn -> 'a = "%reraise"
+ let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} =
+ let open Mty in
+ let loc = sub.location sub loc in
+ let attrs = sub.attributes sub attrs in
+ match desc with
+ | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s)
+ | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s)
+ | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg)
+ | Pmty_functor (s, mt1, mt2) ->
+ functor_ ~loc ~attrs (map_loc sub s)
+ (Misc.may_map (sub.module_type sub) mt1)
+ (sub.module_type sub mt2)
+ | Pmty_with (mt, l) ->
+ with_ ~loc ~attrs (sub.module_type sub mt)
+ (List.map (sub.with_constraint sub) l)
+ | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me)
+ | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x)
-val finally : 'a -> ('a -> 'c) -> ('a -> 'b) -> 'b
+ let map_with_constraint sub = function
+ | Pwith_type (lid, d) ->
+ Pwith_type (map_loc sub lid, sub.type_declaration sub d)
+ | Pwith_module (lid, lid2) ->
+ Pwith_module (map_loc sub lid, map_loc sub lid2)
+ | Pwith_typesubst d -> Pwith_typesubst (sub.type_declaration sub d)
+ | Pwith_modsubst (s, lid) ->
+ Pwith_modsubst (map_loc sub s, map_loc sub lid)
-val with_file_as_chan : string -> (out_channel -> 'a) -> 'a
+ let map_signature_item sub {psig_desc = desc; psig_loc = loc} =
+ let open Sig in
+ let loc = sub.location sub loc in
+ match desc with
+ | Psig_value vd -> value ~loc (sub.value_description sub vd)
+ | Psig_type l -> type_ ~loc (List.map (sub.type_declaration sub) l)
+ | Psig_typext te -> type_extension ~loc (sub.type_extension sub te)
+ | Psig_exception ed -> exception_ ~loc (sub.extension_constructor sub ed)
+ | Psig_module x -> module_ ~loc (sub.module_declaration sub x)
+ | Psig_recmodule l ->
+ rec_module ~loc (List.map (sub.module_declaration sub) l)
+ | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x)
+ | Psig_open x -> open_ ~loc (sub.open_description sub x)
+ | Psig_include x -> include_ ~loc (sub.include_description sub x)
+ | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l)
+ | Psig_class_type l ->
+ class_type ~loc (List.map (sub.class_type_declaration sub) l)
+ | Psig_extension (x, attrs) ->
+ extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs)
+ | Psig_attribute x -> attribute ~loc (sub.attribute sub x)
+end
-val with_file_as_pp : string -> (Format.formatter -> 'a) -> 'a
-val is_pos_pow : Int32.t -> int
+module M = struct
+ (* Value expressions for the module language *)
-val failwithf : loc:string -> ('a, unit, string, 'b) format4 -> 'a
+ let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} =
+ let open Mod in
+ let loc = sub.location sub loc in
+ let attrs = sub.attributes sub attrs in
+ match desc with
+ | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x)
+ | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str)
+ | Pmod_functor (arg, arg_ty, body) ->
+ functor_ ~loc ~attrs (map_loc sub arg)
+ (Misc.may_map (sub.module_type sub) arg_ty)
+ (sub.module_expr sub body)
+ | Pmod_apply (m1, m2) ->
+ apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2)
+ | Pmod_constraint (m, mty) ->
+ constraint_ ~loc ~attrs (sub.module_expr sub m)
+ (sub.module_type sub mty)
+ | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e)
+ | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x)
-val invalid_argf : ('a, unit, string, 'b) format4 -> 'a
-
-val bad_argf : ('a, unit, string, 'b) format4 -> 'a
+ let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} =
+ let open Str in
+ let loc = sub.location sub loc in
+ match desc with
+ | Pstr_eval (x, attrs) ->
+ eval ~loc ~attrs:(sub.attributes sub attrs) (sub.expr sub x)
+ | Pstr_value (r, vbs) ->
+(* XXX *)
+(* value ~loc r (List.map (sub.value_binding sub) vbs) *)
+ value ~loc r
+ ((if r = Recursive then sub.value_bindings_rec else sub.value_bindings)
+ sub vbs)
+(* XXX *)
+ | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd)
+ | Pstr_type l -> type_ ~loc (List.map (sub.type_declaration sub) l)
+ | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te)
+ | Pstr_exception ed -> exception_ ~loc (sub.extension_constructor sub ed)
+ | Pstr_module x -> module_ ~loc (sub.module_binding sub x)
+ | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l)
+ | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x)
+ | Pstr_open x -> open_ ~loc (sub.open_description sub x)
+ | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l)
+ | Pstr_class_type l ->
+ class_type ~loc (List.map (sub.class_type_declaration sub) l)
+ | Pstr_include x -> include_ ~loc (sub.include_declaration sub x)
+ | Pstr_extension (x, attrs) ->
+ extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs)
+ | Pstr_attribute x -> attribute ~loc (sub.attribute sub x)
+end
+module E = struct
+ (* Value expressions for the core language *)
+ let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} =
+ let open Exp in
+ let loc = sub.location sub loc in
+ let attrs = sub.attributes sub attrs in
+ match desc with
+ | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x)
+ | Pexp_constant x -> constant ~loc ~attrs x
+ | Pexp_let (r, vbs, e) ->
+(* XXXX *)
+ (* let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs)
+ (sub.expr sub e) *)
+ let_ ~loc ~attrs r
+ (
+ (if r = Recursive then sub.value_bindings_rec else sub.value_bindings)
+ sub vbs
+ )
+ (sub.expr sub e)
+(* XXXX *)
+ | Pexp_fun (lab, def, p, e) ->
+ fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p)
+ (sub.expr sub e)
+ | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel)
+ | Pexp_apply (e, l) ->
+ apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l)
+ | Pexp_match (e, pel) ->
+ match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
+ | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
+ | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el)
+ | Pexp_construct (lid, arg) ->
+ construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg)
+ | Pexp_variant (lab, eo) ->
+ variant ~loc ~attrs lab (map_opt (sub.expr sub) eo)
+ | Pexp_record (l, eo) ->
+ record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l)
+ (map_opt (sub.expr sub) eo)
+ | Pexp_field (e, lid) ->
+ field ~loc ~attrs (sub.expr sub e) (map_loc sub lid)
+ | Pexp_setfield (e1, lid, e2) ->
+ setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid)
+ (sub.expr sub e2)
+ | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el)
+ | Pexp_ifthenelse (e1, e2, e3) ->
+ ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
+ (map_opt (sub.expr sub) e3)
+ | Pexp_sequence (e1, e2) ->
+ sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
+ | Pexp_while (e1, e2) ->
+ while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
+ | Pexp_for (p, e1, e2, d, e3) ->
+ for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d
+ (sub.expr sub e3)
+ | Pexp_coerce (e, t1, t2) ->
+ coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1)
+ (sub.typ sub t2)
+ | Pexp_constraint (e, t) ->
+ constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t)
+ | Pexp_send (e, s) -> send ~loc ~attrs (sub.expr sub e) s
+ | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid)
+ | Pexp_setinstvar (s, e) ->
+ setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e)
+ | Pexp_override sel ->
+ override ~loc ~attrs
+ (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel)
+ | Pexp_letmodule (s, me, e) ->
+ letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me)
+ (sub.expr sub e)
+ | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e)
+ | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e)
+ | Pexp_poly (e, t) ->
+ poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t)
+ | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls)
+ | Pexp_newtype (s, e) -> newtype ~loc ~attrs s (sub.expr sub e)
+ | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me)
+ | Pexp_open (ovf, lid, e) ->
+ open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e)
+ | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x)
+end
-val dump : 'a -> string
-val pp_any : Format.formatter -> 'a -> unit
-external id : 'a -> 'a = "%identity"
+module P = struct
+ (* Patterns *)
-(** Copied from {!Btype.hash_variant}:
- need sync up and add test case
- *)
-val hash_variant : string -> int
+ let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} =
+ let open Pat in
+ let loc = sub.location sub loc in
+ let attrs = sub.attributes sub attrs in
+ match desc with
+ | Ppat_any -> any ~loc ~attrs ()
+ | Ppat_var s -> var ~loc ~attrs (map_loc sub s)
+ | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s)
+ | Ppat_constant c -> constant ~loc ~attrs c
+ | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2
+ | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl)
+ | Ppat_construct (l, p) ->
+ construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p)
+ | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p)
+ | Ppat_record (lpl, cf) ->
+ record ~loc ~attrs
+ (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf
+ | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl)
+ | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2)
+ | Ppat_constraint (p, t) ->
+ constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t)
+ | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s)
+ | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p)
+ | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s)
+ | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p)
+ | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x)
+end
-end = struct
-#1 "ext_pervasives.ml"
-(* 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 CE = struct
+ (* Value expressions for the class language *)
+ let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} =
+ let open Cl in
+ let loc = sub.location sub loc in
+ let attrs = sub.attributes sub attrs in
+ match desc with
+ | Pcl_constr (lid, tys) ->
+ constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys)
+ | Pcl_structure s ->
+ structure ~loc ~attrs (sub.class_structure sub s)
+ | Pcl_fun (lab, e, p, ce) ->
+ fun_ ~loc ~attrs lab
+ (map_opt (sub.expr sub) e)
+ (sub.pat sub p)
+ (sub.class_expr sub ce)
+ | Pcl_apply (ce, l) ->
+ apply ~loc ~attrs (sub.class_expr sub ce)
+ (List.map (map_snd (sub.expr sub)) l)
+ | Pcl_let (r, vbs, ce) ->
+(* XXXX *)
+ (* let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs)
+ (sub.class_expr sub ce) *)
+ let_ ~loc ~attrs r
+ ((if r = Recursive then sub.value_bindings_rec else sub.value_bindings)
+ sub vbs)
+ (sub.class_expr sub ce)
+(* XXXX *)
+ | Pcl_constraint (ce, ct) ->
+ constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct)
+ | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x)
+ let map_kind sub = function
+ | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e)
+ | Cfk_virtual t -> Cfk_virtual (sub.typ sub t)
+ let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} =
+ let open Cf in
+ let loc = sub.location sub loc in
+ let attrs = sub.attributes sub attrs in
+ match desc with
+ | Pcf_inherit (o, ce, s) -> inherit_ ~loc ~attrs o (sub.class_expr sub ce) s
+ | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k)
+ | Pcf_method (s, p, k) ->
+ method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k)
+ | Pcf_constraint (t1, t2) ->
+ constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2)
+ | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e)
+ | Pcf_attribute x -> attribute ~loc (sub.attribute sub x)
+ | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x)
+ let map_structure sub {pcstr_self; pcstr_fields} =
+ {
+ pcstr_self = sub.pat sub pcstr_self;
+ pcstr_fields = List.map (sub.class_field sub) pcstr_fields;
+ }
+ let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr;
+ pci_loc; pci_attributes} =
+ Ci.mk
+ ~virt:pci_virt
+ ~params:(List.map (map_fst (sub.typ sub)) pl)
+ (map_loc sub pci_name)
+ (f pci_expr)
+ ~loc:(sub.location sub pci_loc)
+ ~attrs:(sub.attributes sub pci_attributes)
+end
-external reraise: exn -> 'a = "%reraise"
+(* Now, a generic AST mapper, to be extended to cover all kinds and
+ cases of the OCaml grammar. The default behavior of the mapper is
+ the identity. *)
-let finally v action f =
- match f v with
- | exception e ->
- action v ;
- reraise e
- | e -> action v ; e
+let default_mapper =
+ {
+ structure = (fun this l -> List.map (this.structure_item this) l);
+ structure_item = M.map_structure_item;
+ module_expr = M.map;
+ signature = (fun this l -> List.map (this.signature_item this) l);
+ signature_item = MT.map_signature_item;
+ module_type = MT.map;
+ with_constraint = MT.map_with_constraint;
+ class_declaration =
+ (fun this -> CE.class_infos this (this.class_expr this));
+ class_expr = CE.map;
+ class_field = CE.map_field;
+ class_structure = CE.map_structure;
+ class_type = CT.map;
+ class_type_field = CT.map_field;
+ class_signature = CT.map_signature;
+ class_type_declaration =
+ (fun this -> CE.class_infos this (this.class_type this));
+ class_description =
+ (fun this -> CE.class_infos this (this.class_type this));
+ type_declaration = T.map_type_declaration;
+ type_kind = T.map_type_kind;
+ typ = T.map;
+ type_extension = T.map_type_extension;
+ extension_constructor = T.map_extension_constructor;
+ value_description =
+ (fun this {pval_name; pval_type; pval_prim; pval_loc;
+ pval_attributes} ->
+ Val.mk
+ (map_loc this pval_name)
+ (this.typ this pval_type)
+ ~attrs:(this.attributes this pval_attributes)
+ ~loc:(this.location this pval_loc)
+ ~prim:pval_prim
+ );
-let with_file_as_chan filename f =
- finally (open_out_bin filename) close_out f
+ pat = P.map;
+ expr = E.map;
-let with_file_as_pp filename f =
- finally (open_out_bin filename) close_out
- (fun chan ->
- let fmt = Format.formatter_of_out_channel chan in
+ module_declaration =
+ (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} ->
+ Md.mk
+ (map_loc this pmd_name)
+ (this.module_type this pmd_type)
+ ~attrs:(this.attributes this pmd_attributes)
+ ~loc:(this.location this pmd_loc)
+ );
+
+ module_type_declaration =
+ (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} ->
+ Mtd.mk
+ (map_loc this pmtd_name)
+ ?typ:(map_opt (this.module_type this) pmtd_type)
+ ~attrs:(this.attributes this pmtd_attributes)
+ ~loc:(this.location this pmtd_loc)
+ );
+
+ module_binding =
+ (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} ->
+ Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr)
+ ~attrs:(this.attributes this pmb_attributes)
+ ~loc:(this.location this pmb_loc)
+ );
+
+
+ open_description =
+ (fun this {popen_lid; popen_override; popen_attributes; popen_loc} ->
+ Opn.mk (map_loc this popen_lid)
+ ~override:popen_override
+ ~loc:(this.location this popen_loc)
+ ~attrs:(this.attributes this popen_attributes)
+ );
+
+
+ include_description =
+ (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
+ Incl.mk (this.module_type this pincl_mod)
+ ~loc:(this.location this pincl_loc)
+ ~attrs:(this.attributes this pincl_attributes)
+ );
+
+ include_declaration =
+ (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
+ Incl.mk (this.module_expr this pincl_mod)
+ ~loc:(this.location this pincl_loc)
+ ~attrs:(this.attributes this pincl_attributes)
+ );
+
+ value_bindings = (fun this vbs ->
+ match vbs with
+ | [vb] -> [ this.value_binding this vb ]
+ | _ -> List.map (this.value_binding this) vbs
+ );
+ value_bindings_rec = (fun this vbs ->
+ match vbs with
+ | [vb] -> [ this.value_binding this vb ]
+ | _ -> List.map (this.value_binding this) vbs
+ );
+ value_binding =
+ (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} ->
+ Vb.mk
+ (this.pat this pvb_pat)
+ (this.expr this pvb_expr)
+ ~loc:(this.location this pvb_loc)
+ ~attrs:(this.attributes this pvb_attributes)
+ );
+
+
+ constructor_declaration =
+ (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} ->
+ Type.constructor
+ (map_loc this pcd_name)
+ ~args:(List.map (this.typ this) pcd_args)
+ ?res:(map_opt (this.typ this) pcd_res)
+ ~loc:(this.location this pcd_loc)
+ ~attrs:(this.attributes this pcd_attributes)
+ );
+
+ label_declaration =
+ (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} ->
+ Type.field
+ (map_loc this pld_name)
+ (this.typ this pld_type)
+ ~mut:pld_mutable
+ ~loc:(this.location this pld_loc)
+ ~attrs:(this.attributes this pld_attributes)
+ );
+
+ cases = (fun this l -> List.map (this.case this) l);
+ case =
+ (fun this {pc_lhs; pc_guard; pc_rhs} ->
+ {
+ pc_lhs = this.pat this pc_lhs;
+ pc_guard = map_opt (this.expr this) pc_guard;
+ pc_rhs = this.expr this pc_rhs;
+ }
+ );
+
+
+
+ location = (fun this l -> l);
+
+ extension = (fun this (s, e) -> (map_loc this s, this.payload this e));
+ attribute = (fun this (s, e) -> (map_loc this s, this.payload this e));
+ attributes = (fun this l -> List.map (this.attribute this) l);
+ payload =
+ (fun this -> function
+ | PStr x -> PStr (this.structure this x)
+ | PTyp x -> PTyp (this.typ this x)
+ | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g)
+ );
+ }
+end
+module Ext_pervasives : sig
+#1 "ext_pervasives.mli"
+(* 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. *)
+
+
+
+
+
+
+
+
+(** Extension to standard library [Pervavives] module, safe to open
+ *)
+
+external reraise: exn -> 'a = "%reraise"
+
+val finally : 'a -> ('a -> 'c) -> ('a -> 'b) -> 'b
+
+val with_file_as_chan : string -> (out_channel -> 'a) -> 'a
+
+val with_file_as_pp : string -> (Format.formatter -> 'a) -> 'a
+
+val is_pos_pow : Int32.t -> int
+
+val failwithf : loc:string -> ('a, unit, string, 'b) format4 -> 'a
+
+val invalid_argf : ('a, unit, string, 'b) format4 -> 'a
+
+val bad_argf : ('a, unit, string, 'b) format4 -> 'a
+
+
+
+val dump : 'a -> string
+val pp_any : Format.formatter -> 'a -> unit
+external id : 'a -> 'a = "%identity"
+
+(** Copied from {!Btype.hash_variant}:
+ need sync up and add test case
+ *)
+val hash_variant : string -> int
+
+end = struct
+#1 "ext_pervasives.ml"
+(* 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. *)
+
+
+
+
+
+
+external reraise: exn -> 'a = "%reraise"
+
+let finally v action f =
+ match f v with
+ | exception e ->
+ action v ;
+ reraise e
+ | e -> action v ; e
+
+let with_file_as_chan filename f =
+ finally (open_out_bin filename) close_out f
+
+let with_file_as_pp filename f =
+ finally (open_out_bin filename) close_out
+ (fun chan ->
+ let fmt = Format.formatter_of_out_channel chan in
let v = f fmt in
Format.pp_print_flush fmt ();
v
@@ -13033,9 +13445,9 @@ let is_enum_constructors
)
constructors
end
-module Ast_derive_js_mapper : sig
-#1 "ast_derive_js_mapper.mli"
-(* Copyright (C) 2017 Authors of BuckleScript
+module Bs_loc : sig
+#1 "bs_loc.mli"
+(* 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
@@ -13059,12 +13471,20 @@ module Ast_derive_js_mapper : sig
* 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 = Location.t = {
+ loc_start : Lexing.position;
+ loc_end : Lexing.position ;
+ loc_ghost : bool
+}
+
+val is_ghost : t -> bool
+val merge : t -> t -> t
+val none : t
-val init : unit -> unit
end = struct
-#1 "ast_derive_js_mapper.ml"
-(* Copyright (C) 2017 Authors of BuckleScript
+#1 "bs_loc.ml"
+(* 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
@@ -13088,493 +13508,518 @@ end = struct
* 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 U = Ast_derive_util
-type tdcls = Parsetree.type_declaration list
-let js_field (o : Parsetree.expression) m =
- Exp.apply
- (Exp.ident {txt = Lident "##"; loc = o.pexp_loc})
- [
- "",o;
- "", Exp.ident m
- ]
-let const_int i = Exp.constant (Const_int i)
-let const_string s = Exp.constant (Const_string (s,None))
+type t = Location.t = {
+ loc_start : Lexing.position;
+ loc_end : Lexing.position ;
+ loc_ghost : bool
+}
+let is_ghost x = x.loc_ghost
-let handle_config (config : Parsetree.expression option) =
- match config with
- | Some config ->
- (match config.pexp_desc with
- | Pexp_record (
- [
- {txt = Lident "newType"},
- {pexp_desc =
- (Pexp_construct
- (
- {txt =
- Lident ("true"
- | "false"
- as x)}, None)
- | Pexp_ident {txt = Lident ("newType" as x)}
- )
- }
- ],None)
- -> not (x = "false")
- | Pexp_ident {txt = Lident ("newType")}
- -> true
- | _ -> U.invalid_config config)
- | None -> false
-let noloc = Location.none
-(* [eraseType] will be instrumented, be careful about the name conflict*)
-let eraseTypeLit = "jsMapperEraseType"
-let eraseTypeExp = Exp.ident {loc = noloc; txt = Lident eraseTypeLit}
-let eraseType x =
- Exp.apply eraseTypeExp ["", x]
-let eraseTypeStr =
- let any = Typ.any () in
- Str.primitive
- (Val.mk ~prim:["%identity"] {loc = noloc; txt = eraseTypeLit}
- (Typ.arrow "" any any)
- )
+let merge (l: t) (r : t) =
+ if is_ghost l then r
+ else if is_ghost r then l
+ else match l,r with
+ | {loc_start ; }, {loc_end; _} (* TODO: improve*)
+ ->
+ {loc_start ;loc_end; loc_ghost = false}
-let app2 f arg1 arg2 =
- Exp.apply f ["",arg1; "", arg2]
-let app3 f arg1 arg2 arg3 =
- Exp.apply f ["", arg1; "", arg2; "", arg3]
-let (<=~) a b =
- app2 (Exp.ident {loc = noloc; txt = Lident "<="}) a b
-let (-~) a b =
- app2 (Exp.ident {loc = noloc; txt = Ldot(Lident "Pervasives","-")})
- a b
-let (+~) a b =
- app2 (Exp.ident {loc = noloc; txt = Ldot(Lident "Pervasives","+")})
- a b
-let (&&~) a b =
- app2 (Exp.ident {loc = noloc; txt = Ldot(Lident "Pervasives","&&")})
- a b
-let (->~) a b = Typ.arrow "" a b
-let jsMapperRt =
- Longident.Ldot (Lident "Js", "MapperRt")
+let none = Location.none
-let search upper polyvar array =
- app3
- (Exp.ident ({loc = noloc;
- txt = Longident.Ldot (jsMapperRt,"binarySearch") })
- )
- upper
- (eraseType polyvar)
- array
+end
+module Bs_version : sig
+#1 "bs_version.mli"
+(* 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 revSearch len constantArray exp =
- app3
- (Exp.ident
- {loc= noloc;
- txt = Longident.Ldot (jsMapperRt, "revSearch")})
- len
- constantArray
- exp
+val version : string
-let revSearchAssert len constantArray exp =
- app3
- (Exp.ident
- {loc= noloc;
- txt = Longident.Ldot (jsMapperRt, "revSearchAssert")})
- len
- constantArray
- exp
+val header : string
-let toInt exp array =
- app2
- (Exp.ident
- { loc=noloc;
- txt = Longident.Ldot (jsMapperRt, "toInt")})
- (eraseType exp)
- array
-let fromInt len array exp =
- app3
- (Exp.ident
- {loc = noloc;
- txt = Longident.Ldot (jsMapperRt,"fromInt")})
- len
- array
- exp
+val package_name : string
+end = struct
+#1 "bs_version.ml"
-let fromIntAssert len array exp =
- app3
- (Exp.ident
- {loc = noloc;
- txt = Longident.Ldot (jsMapperRt,"fromIntAssert")})
- len
- array
- exp
+(* 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 version = "2.2.3"
+let header =
+ "// Generated by BUCKLESCRIPT VERSION 2.2.3, PLEASE EDIT WITH CARE"
+let package_name = "bs-platform"
+
+end
+module External_ffi_types : sig
+#1 "external_ffi_types.mli"
+(* 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 module_bind_name =
+ | Phint_name of string
+ (* explicit hint name *)
+ | Phint_nothing
-let assertExp e =
- Exp.extension
- ({Asttypes.loc = noloc; txt = "assert"},
- (PStr
- [Str.eval e ]
- )
- )
-let derivingName = "jsConverter"
+type external_module_name =
+ { bundle : string ;
+ module_bind_name : module_bind_name
+ }
-(* let notApplicable loc =
- Location.prerr_warning
- loc
- (Warnings.Bs_derive_warning ( derivingName ^ " not applicable to this type")) *)
+type pipe = bool
+type js_call = {
+ name : string;
+ external_module_name : external_module_name option;
+ splice : bool ;
+ scopes : string list
+}
-let init () =
- Ast_derive.register
- derivingName
- (fun ( x : Parsetree.expression option) ->
- let createType = handle_config x in
+type js_send = {
+ name : string ;
+ splice : bool ;
+ pipe : pipe ;
+ js_send_scopes : string list;
+} (* we know it is a js send, but what will happen if you pass an ocaml objct *)
- {
- structure_gen = (fun (tdcls : tdcls) _ ->
- let handle_tdcl (tdcl: Parsetree.type_declaration) =
- let core_type = U.core_type_of_type_declaration tdcl
- in
- let name = tdcl.ptype_name.txt in
- let toJs = name ^ "ToJs" in
- let fromJs = name ^ "FromJs" in
- let constantArray = "jsMapperConstantArray" in
- let loc = tdcl.ptype_loc in
- let patToJs = {Asttypes.loc; txt = toJs} in
- let patFromJs = {Asttypes.loc; txt = fromJs} in
- let param = "param" in
+type js_global_val = {
+ name : string ;
+ external_module_name : external_module_name option;
+ scopes : string list
+}
- let ident_param = {Asttypes.txt = Longident.Lident param; loc} in
- let pat_param = {Asttypes.loc; txt = param} in
- let exp_param = Exp.ident ident_param in
- let newType,newTdcl =
- U.new_type_of_type_declaration tdcl ("abs_" ^ name) in
- let newTypeStr = Str.type_ [newTdcl] in
- let toJsBody body =
- Ast_comb.single_non_rec_value patToJs
- (Exp.fun_ "" None (Pat.constraint_ (Pat.var pat_param) core_type)
- body )
- in
- let (+>) a ty =
- Exp.constraint_ (eraseType a) ty in
- let (+:) a ty =
- eraseType (Exp.constraint_ a ty) in
- let coerceResultToNewType e =
- if createType then
- e +> newType
- else e
- in
- match tdcl.ptype_kind with
- | Ptype_record label_declarations ->
- let exp =
- coerceResultToNewType
- (Exp.extension
- (
- {Asttypes.loc; txt = "bs.obj"},
- (PStr
- [Str.eval
- (Exp.record
- (List.map
- (fun ({pld_name = {loc; txt } } : Parsetree.label_declaration) ->
- let label =
- {Asttypes.loc; txt = Longident.Lident txt } in
- label,Exp.field exp_param label
- ) label_declarations) None)]))) in
- let toJs =
- toJsBody exp
- in
- let obj_exp =
- Exp.record
- (List.map
- (fun ({pld_name = {loc; txt } } : Parsetree.label_declaration) ->
- let label =
- {Asttypes.loc; txt = Longident.Lident txt } in
- label,
- js_field exp_param label
- ) label_declarations) None in
- let fromJs =
- Ast_comb.single_non_rec_value patFromJs
- (Exp.fun_ "" None (Pat.var pat_param)
- (if createType then
- (Exp.let_ Nonrecursive
- [Vb.mk
- (Pat.var pat_param)
- (exp_param +: newType)]
- (Exp.constraint_ obj_exp core_type) )
- else
- (Exp.constraint_ obj_exp core_type) ))
- in
- let rest =
- [
- toJs;
- fromJs
- ] in
- if createType then eraseTypeStr:: newTypeStr :: rest else rest
- | Ptype_abstract ->
- (match Ast_polyvar.is_enum_polyvar tdcl with
- | Some row_fields ->
- let attr =
- Ast_polyvar.map_row_fields_into_strings loc row_fields
- in
- let expConstantArray =
- Exp.ident {loc; txt = Longident.Lident constantArray} in
- begin match attr with
- | NullString result ->
- let result_len = List.length result in
- let exp_len = const_int result_len in
- let v = [
- eraseTypeStr;
- Ast_comb.single_non_rec_value
- {loc; txt = constantArray}
- (Exp.array
- (List.map (fun (i,str) ->
- Exp.tuple
- [
- const_int i;
- const_string str
- ]
- ) (List.sort (fun (a,_) (b,_) -> compare (a:int) b) result)));
- (
- toJsBody
- (coerceResultToNewType
- (search
- exp_len
- exp_param
- expConstantArray
- ))
- );
- Ast_comb.single_non_rec_value
- patFromJs
- (Exp.fun_ "" None
- (Pat.var pat_param)
- (if createType then
- revSearchAssert
- exp_len
- expConstantArray
- (exp_param +: newType)
- +>
- core_type
- else
- revSearch
- exp_len
- expConstantArray
- exp_param
- +>
- Ast_core_type.lift_option_type core_type
- )
- )
- ] in
- if createType then
- newTypeStr :: v
- else v
- | _ -> assert false
- end
- | None ->
- U.notApplicable
- tdcl.Parsetree.ptype_loc
- derivingName;
- []
- )
+type js_new_val = {
+ name : string ;
+ external_module_name : external_module_name option;
+ splice : bool ;
+ scopes : string list;
+}
+
+type js_module_as_fn =
+ { external_module_name : external_module_name;
+ splice : bool
+ }
+
+type arg_type = External_arg_spec.attr
+
+type arg_label = External_arg_spec.label
+
+
+type obj_create = External_arg_spec.t list
+
+type js_get =
+ { js_get_name : string ;
+ js_get_scopes : string list;
+ }
+
+type js_set =
+ { js_set_name : string ;
+ js_set_scopes : string list
+ }
+
+
+type js_get_index = {
+ js_get_index_scopes : string list
+}
+
+type js_set_index = {
+ js_set_index_scopes : string list
+}
+
+
+
+type attr =
+ | Js_global of js_global_val
+ | Js_module_as_var of external_module_name
+ | Js_module_as_fn of js_module_as_fn
+ | Js_module_as_class of external_module_name
+ | Js_call of js_call
+ | Js_send of js_send
+ | Js_new of js_new_val
+ | Js_set of js_set
+ | Js_get of js_get
+ | Js_get_index of js_get_index
+ | Js_set_index of js_set_index
+
+type return_wrapper =
+ | Return_unset
+ | Return_identity
+ | Return_undefined_to_opt
+ | Return_null_to_opt
+ | Return_null_undefined_to_opt
+ | Return_to_ocaml_bool
+ | Return_replaced_with_unit
+
+type t =
+ | Ffi_bs of
+ External_arg_spec.t list *
+ return_wrapper * attr
+ | Ffi_obj_create of obj_create
+ | Ffi_normal
+ (* When it's normal, it is handled as normal c functional ffi call *)
+
+
+val name_of_ffi : attr -> string
+
+val check_ffi : ?loc:Location.t -> attr -> unit
+
+val to_string : t -> string
+
+(** Note *)
+val from_string : string -> t
+
+
+end = struct
+#1 "external_ffi_types.ml"
+(* 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 module_bind_name =
+ | Phint_name of string
+ (* explicit hint name *)
+
+ | Phint_nothing
+
+
+type external_module_name =
+ { bundle : string ;
+ module_bind_name : module_bind_name
+ }
+
+type pipe = bool
+type js_call = {
+ name : string;
+ external_module_name : external_module_name option;
+ splice : bool ;
+ scopes : string list ;
+}
+
+type js_send = {
+ name : string ;
+ splice : bool ;
+ pipe : pipe ;
+ js_send_scopes : string list;
+} (* we know it is a js send, but what will happen if you pass an ocaml objct *)
+
+type js_global_val = {
+ name : string ;
+ external_module_name : external_module_name option;
+ scopes : string list ;
+}
+
+type js_new_val = {
+ name : string ;
+ external_module_name : external_module_name option;
+ splice : bool ;
+ scopes : string list;
+}
+
+type js_module_as_fn =
+ { external_module_name : external_module_name;
+ splice : bool ;
+
+ }
+type js_get =
+ { js_get_name : string ;
+ js_get_scopes : string list;
+ }
+
+type js_set =
+ { js_set_name : string ;
+ js_set_scopes : string list
+ }
+
+type js_get_index = {
+ js_get_index_scopes : string list
+}
+
+type js_set_index = {
+ js_set_index_scopes : string list
+}
+(** TODO: information between [arg_type] and [arg_label] are duplicated,
+ design a more compact representation so that it is also easy to seralize by hand
+*)
+type arg_type = External_arg_spec.attr
+
+type arg_label = External_arg_spec.label
+
+
+(**TODO: maybe we can merge [arg_label] and [arg_type] *)
+type obj_create = External_arg_spec.t list
- | Ptype_variant ctors ->
- if Ast_polyvar.is_enum_constructors ctors then
- let xs = Ast_polyvar.map_constructor_declarations_into_ints ctors in
- match xs with
- | `New xs ->
- let constantArrayExp = Exp.ident {loc; txt = Lident constantArray} in
- let exp_len = const_int (List.length ctors) in
- let v = [
- eraseTypeStr;
- Ast_comb.single_non_rec_value
- {loc; txt = constantArray}
- (Exp.array (List.map (fun i -> const_int i) xs ))
- ;
- toJsBody
- (
- coerceResultToNewType @@
- toInt
- exp_param
- constantArrayExp
- )
- ;
- Ast_comb.single_non_rec_value
- patFromJs
- (Exp.fun_ "" None
- (Pat.var pat_param)
- (
- if createType then
- fromIntAssert
- exp_len
- constantArrayExp
- (exp_param +: newType)
- +>
- core_type
- else
- fromInt
- exp_len
- constantArrayExp
- exp_param
- +>
- Ast_core_type.lift_option_type core_type
+type attr =
+ | Js_global of js_global_val
+ | Js_module_as_var of external_module_name
+ | Js_module_as_fn of js_module_as_fn
+ | Js_module_as_class of external_module_name
+ | Js_call of js_call
+ | Js_send of js_send
+ | Js_new of js_new_val
+ | Js_set of js_set
+ | Js_get of js_get
+ | Js_get_index of js_get_index
+ | Js_set_index of js_set_index
- )
- )
- ] in
- if createType then newTypeStr :: v else v
- | `Offset offset ->
- let v =
- [ eraseTypeStr;
- toJsBody (
- coerceResultToNewType
- (eraseType exp_param +~ const_int offset)
- )
- ;
- let len = List.length ctors in
- let range_low = const_int (offset + 0) in
- let range_upper = const_int (offset + len - 1) in
+let name_of_ffi ffi =
+ match ffi with
+ | Js_get_index _scope -> "[@@bs.get_index ..]"
+ | Js_set_index _scope -> "[@@bs.set_index ..]"
+ | Js_get { js_get_name = s} -> Printf.sprintf "[@@bs.get %S]" s
+ | Js_set { js_set_name = s} -> Printf.sprintf "[@@bs.set %S]" s
+ | Js_call v -> Printf.sprintf "[@@bs.val %S]" v.name
+ | Js_send v -> Printf.sprintf "[@@bs.send %S]" v.name
+ | Js_module_as_fn v -> Printf.sprintf "[@@bs.val %S]" v.external_module_name.bundle
+ | Js_new v -> Printf.sprintf "[@@bs.new %S]" v.name
+ | Js_module_as_class v
+ -> Printf.sprintf "[@@bs.module] %S " v.bundle
+ | Js_module_as_var v
+ ->
+ Printf.sprintf "[@@bs.module] %S " v.bundle
+ | Js_global v
+ ->
+ Printf.sprintf "[@@bs.val] %S " v.name
+
+type return_wrapper =
+ | Return_unset
+ | Return_identity
+ | Return_undefined_to_opt
+ | Return_null_to_opt
+ | Return_null_undefined_to_opt
+ | Return_to_ocaml_bool
+ | Return_replaced_with_unit
+type t =
+ | Ffi_bs of External_arg_spec.t list *
+ return_wrapper * attr
+ (** [Ffi_bs(args,return,attr) ]
+ [return] means return value is unit or not,
+ [true] means is [unit]
+ *)
+ | Ffi_obj_create of obj_create
+ | Ffi_normal
+ (* When it's normal, it is handled as normal c functional ffi call *)
+
+
+
+let valid_js_char =
+ let a = Array.init 256 (fun i ->
+ let c = Char.chr i in
+ (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || (c >= '0' && c <= '9') || c = '_' || c = '$'
+ ) in
+ (fun c -> Array.unsafe_get a (Char.code c))
+
+let valid_first_js_char =
+ let a = Array.init 256 (fun i ->
+ let c = Char.chr i in
+ (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || c = '_' || c = '$'
+ ) in
+ (fun c -> Array.unsafe_get a (Char.code c))
+
+(** Approximation could be improved *)
+let valid_ident (s : string) =
+ let len = String.length s in
+ len > 0 && valid_js_char s.[0] && valid_first_js_char s.[0] &&
+ (let module E = struct exception E end in
+ try
+ for i = 1 to len - 1 do
+ if not (valid_js_char (String.unsafe_get s i)) then
+ raise E.E
+ done ;
+ true
+ with E.E -> false )
+
+let valid_global_name ?loc txt =
+ if not (valid_ident txt) then
+ let v = Ext_string.split_by ~keep_empty:true (fun x -> x = '.') txt in
+ List.iter
+ (fun s ->
+ if not (valid_ident s) then
+ Location.raise_errorf ?loc "Not a valid global name %s" txt
+ ) v
+
+let valid_method_name ?loc txt =
+ if not (valid_ident txt) then
+ Location.raise_errorf ?loc "Not a valid method name %s" txt
+
+
+
+let check_external_module_name ?loc x =
+ match x with
+ | {bundle = ""; _ }
+ | { module_bind_name = Phint_name "" } ->
+ Location.raise_errorf ?loc "empty name encountered"
+ | _ -> ()
+let check_external_module_name_opt ?loc x =
+ match x with
+ | None -> ()
+ | Some v -> check_external_module_name ?loc v
+
+
+let check_ffi ?loc ffi =
+ match ffi with
+ | Js_global {name} -> valid_global_name ?loc name
+ | Js_send {name }
+ | Js_set {js_set_name = name}
+ | Js_get { js_get_name = name}
+ -> valid_method_name ?loc name
+ | Js_get_index _ (* TODO: check scopes *)
+ | Js_set_index _
+ -> ()
+
+ | Js_module_as_var external_module_name
+ | Js_module_as_fn {external_module_name; _}
+ | Js_module_as_class external_module_name
+ -> check_external_module_name external_module_name
+ | Js_new {external_module_name ; name}
+ | Js_call {external_module_name ; name ; _}
+ ->
+ check_external_module_name_opt ?loc external_module_name ;
+ valid_global_name ?loc name
+
+let bs_prefix = "BS:"
+let bs_prefix_length = String.length bs_prefix
+
+
+(** TODO: Make sure each version is not prefix of each other
+ Solution:
+ 1. fixed length
+ 2. non-prefix approach
+*)
+let bs_external = bs_prefix ^ Bs_version.version
- Ast_comb.single_non_rec_value
- {loc ; txt = fromJs}
- (Exp.fun_ "" None
- (Pat.var pat_param)
- (if createType then
- (Exp.let_ Nonrecursive
- [Vb.mk
- (Pat.var pat_param)
- (exp_param +: newType)
- ]
- (
- Exp.sequence
- (assertExp
- ((exp_param <=~ range_upper) &&~ (range_low <=~ exp_param))
- )
- (exp_param -~ const_int offset))
- )
- +>
- core_type
- else
- (Exp.ifthenelse
- ( (exp_param <=~ range_upper) &&~ (range_low <=~ exp_param))
- (Exp.construct {loc; txt = Lident "Some"}
- ( Some (exp_param -~ const_int offset)))
- (Some (Exp.construct {loc; txt = Lident "None"} None)))
- +>
- Ast_core_type.lift_option_type core_type
- )
- )
- ] in
- if createType then newTypeStr :: v else v
- else
- begin
- U.notApplicable
- tdcl.Parsetree.ptype_loc
- derivingName;
- []
- end
- | Ptype_open ->
- U.notApplicable tdcl.Parsetree.ptype_loc
- derivingName;
- [] in
- Ext_list.flat_map handle_tdcl tdcls
- );
- signature_gen =
- (fun (tdcls : tdcls) _ ->
- let handle_tdcl tdcl =
- let core_type = U.core_type_of_type_declaration tdcl
- in
- let name = tdcl.ptype_name.txt in
- let toJs = name ^ "ToJs" in
- let fromJs = name ^ "FromJs" in
- let loc = tdcl.ptype_loc in
- let patToJs = {Asttypes.loc; txt = toJs} in
- let patFromJs = {Asttypes.loc; txt = fromJs} in
- let toJsType result =
- Ast_comb.single_non_rec_val patToJs (Typ.arrow "" core_type result) in
- let newType,newTdcl =
- U.new_type_of_type_declaration tdcl ("abs_" ^ name) in
- let newTypeStr = Sig.type_ [newTdcl] in
- let (+?) v rest = if createType then v :: rest else rest in
- match tdcl.ptype_kind with
- | Ptype_record label_declarations ->
- let objType flag =
- Ast_comb.to_js_type loc @@
- Typ.object_
- (List.map
- (fun ({pld_name = {loc; txt }; pld_type } : Parsetree.label_declaration) ->
- txt, [], pld_type
- ) label_declarations)
- flag in
- newTypeStr +?
- [
- toJsType (if createType then newType else objType Closed);
- Ast_comb.single_non_rec_val patFromJs
- ( (if createType then newType else objType Open)->~ core_type)
- ]
+let bs_external_length = String.length bs_external
- | Ptype_abstract ->
- (match Ast_polyvar.is_enum_polyvar tdcl with
- | Some _ ->
- let ty1 =
- if createType then newType else
- (Ast_literal.type_string ()) in
- let ty2 =
- if createType then core_type
- else Ast_core_type.lift_option_type core_type in
- newTypeStr +?
- [
- toJsType ty1;
- Ast_comb.single_non_rec_val
- patFromJs
- (ty1 ->~ ty2)
- ]
- | None ->
- U.notApplicable tdcl.Parsetree.ptype_loc
- derivingName;
- [])
+let to_string t =
+ bs_external ^ Marshal.to_string t []
- | Ptype_variant ctors
- ->
- if Ast_polyvar.is_enum_constructors ctors then
- let ty1 =
- if createType then newType
- else Ast_literal.type_int() in
- let ty2 =
- if createType then core_type
- else Ast_core_type.lift_option_type core_type in
- newTypeStr +?
- [
- toJsType ty1;
- Ast_comb.single_non_rec_val
- patFromJs
- (ty1 ->~ ty2)
- ]
+(* TODO: better error message when version mismatch *)
+let from_string s : t =
+ let s_len = String.length s in
+ if s_len >= bs_prefix_length &&
+ String.unsafe_get s 0 = 'B' &&
+ String.unsafe_get s 1 = 'S' &&
+ String.unsafe_get s 2 = ':' then
+ if Ext_string.starts_with s bs_external then
+ Marshal.from_string s bs_external_length
+ else
+ Ext_pervasives.failwithf
+ ~loc:__LOC__
+ "Compiler version mismatch. The project might have been built with one version of BuckleScript, and then with another. Please wipe the artifacts and do a clean build."
+ else Ffi_normal
- else
- begin
- U.notApplicable tdcl.Parsetree.ptype_loc
- derivingName;
- []
- end
- | Ptype_open ->
- U.notApplicable tdcl.Parsetree.ptype_loc
- derivingName;
- [] in
- Ext_list.flat_map handle_tdcl tdcls
+end
+module Bs_hash_stubs
+= struct
+#1 "bs_hash_stubs.ml"
- );
- expression_gen = None
- }
- )
-;
+
+external hash_string : string -> int = "caml_bs_hash_string" "noalloc";;
+
+external hash_string_int : string -> int -> int = "caml_bs_hash_string_and_int" "noalloc";;
+
+external hash_string_small_int : string -> int -> int = "caml_bs_hash_string_and_small_int" "noalloc";;
+
+external hash_stamp_and_name : int -> string -> int = "caml_bs_hash_stamp_and_name" "noalloc";;
+
+external hash_small_int : int -> int = "caml_bs_hash_small_int" "noalloc";;
+
+external hash_int : int -> int = "caml_bs_hash_int" "noalloc";;
+
+external string_length_based_compare : string -> string -> int = "caml_string_length_based_compare" "noalloc";;
+
+
+external
+ int_unsafe_blit :
+ int array -> int -> int array -> int -> int -> unit = "caml_int_array_blit" "noalloc";;
+
end
-module Ast_derive_projector : sig
-#1 "ast_derive_projector.mli"
-(* Copyright (C) 2017 Authors of BuckleScript
+module String_hash_set : sig
+#1 "string_hash_set.mli"
+(* 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
@@ -13599,138 +14044,107 @@ module Ast_derive_projector : sig
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-
-val init : unit -> unit
+include Hash_set_gen.S with type key = string
end = struct
-#1 "ast_derive_projector.ml"
-open Ast_helper
+#1 "string_hash_set.ml"
+# 1 "ext/hash_set.cppo.ml"
+(* 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. *)
+# 31
+type key = string
+let key_index (h : _ Hash_set_gen.t ) (key : key) =
+ (Bs_hash_stubs.hash_string key) land (Array.length h.data - 1)
+let eq_key = Ext_string.equal
+type t = key Hash_set_gen.t
-let invalid_config (config : Parsetree.expression) =
- Location.raise_errorf ~loc:config.pexp_loc "such configuration is not supported"
+# 62
+let create = Hash_set_gen.create
+let clear = Hash_set_gen.clear
+let reset = Hash_set_gen.reset
+let copy = Hash_set_gen.copy
+let iter = Hash_set_gen.iter
+let fold = Hash_set_gen.fold
+let length = Hash_set_gen.length
+let stats = Hash_set_gen.stats
+let elements = Hash_set_gen.elements
-type tdcls = Parsetree.type_declaration list
-let derivingName = "accessors"
-let init () =
-
- Ast_derive.register
- derivingName
- (fun (x : Parsetree.expression option) ->
- (match x with
- | Some config -> invalid_config config
- | None -> ());
- {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
- ->
- label_declarations
- |> Ext_list.map (
- 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
- (Exp.fun_ "" None
- (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
- ->
- constructor_declarations
- |> Ext_list.map
- (fun
- ( {pcd_name = {loc ; txt = con_name} ; pcd_args ; pcd_loc }:
- Parsetree.constructor_declaration)
- -> (* TODO: add type annotations *)
- let little_con_name = String.uncapitalize con_name in
- let arity = List.length pcd_args 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)
- core_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 = Longident.Lident (List.hd vars )}
- else
- Exp.tuple (Ext_list.map
- (fun x -> Exp.ident {loc ; txt = Longident.Lident x})
- vars
- ) )) core_type
- in
- Ext_list.fold_right (fun var b ->
- Exp.fun_ "" None (Pat.var {loc ; txt = var}) b
- ) vars exp
+let remove (h : _ Hash_set_gen.t) key =
+ let i = key_index h key in
+ let h_data = h.data in
+ let old_h_size = h.size in
+ let new_bucket = Hash_set_gen.remove_bucket eq_key key h (Array.unsafe_get h_data i) in
+ if old_h_size <> h.size then
+ Array.unsafe_set h_data i new_bucket
- 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 handle_tdcl tdcls
- 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
- ->
- label_declarations
- |> Ext_list.map
- (fun
- ({pld_name ;
- pld_type
- } :
- Parsetree.label_declaration) ->
- Ast_comb.single_non_rec_val pld_name (Typ.arrow "" core_type pld_type )
- )
- | Ptype_variant constructor_declarations
- ->
- constructor_declarations
- |>
- Ext_list.map
- (fun ({pcd_name = {loc ; txt = con_name} ; pcd_args ; pcd_loc }:
- Parsetree.constructor_declaration)
- ->
- Ast_comb.single_non_rec_val {loc ; txt = (String.uncapitalize con_name)}
- (Ext_list.fold_right
- (fun x acc -> Typ.arrow "" x acc)
- pcd_args
- core_type))
- | Ptype_open | Ptype_abstract ->
- Ast_derive_util.notApplicable tdcl.ptype_loc derivingName ;
- []
- in
- Ext_list.flat_map handle_tdcl tdcls
- end;
- expression_gen = None
- }
- )
+let add (h : _ Hash_set_gen.t) key =
+ let i = key_index h key in
+ let h_data = h.data in
+ let old_bucket = (Array.unsafe_get h_data i) in
+ if not (Hash_set_gen.small_bucket_mem eq_key key old_bucket) then
+ begin
+ Array.unsafe_set h_data i (key :: old_bucket);
+ h.size <- h.size + 1 ;
+ if h.size > Array.length h_data lsl 1 then Hash_set_gen.resize key_index h
+ end
+
+let of_array arr =
+ let len = Array.length arr in
+ let tbl = create len in
+ for i = 0 to len - 1 do
+ add tbl (Array.unsafe_get arr i);
+ done ;
+ tbl
+
+
+let check_add (h : _ Hash_set_gen.t) key =
+ let i = key_index h key in
+ let h_data = h.data in
+ let old_bucket = (Array.unsafe_get h_data i) in
+ if not (Hash_set_gen.small_bucket_mem eq_key key old_bucket) then
+ begin
+ Array.unsafe_set h_data i (key :: old_bucket);
+ h.size <- h.size + 1 ;
+ if h.size > Array.length h_data lsl 1 then Hash_set_gen.resize key_index h;
+ true
+ end
+ else false
+
+
+let mem (h : _ Hash_set_gen.t) key =
+ Hash_set_gen.small_bucket_mem eq_key key (Array.unsafe_get h.data (key_index h key))
+
end
-module Ext_char : sig
-#1 "ext_char.mli"
+module Lam_methname : sig
+#1 "lam_methname.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -13757,21 +14171,12 @@ module Ext_char : sig
+val translate : ?loc:Location.t -> string -> string
-
-
-(** Extension to Standard char module, avoid locale sensitivity *)
-
-val escaped : char -> string
-
-
-val valid_hex : char -> bool
-
-val is_lower_case : char -> bool
end = struct
-#1 "ext_char.ml"
+#1 "lam_methname.ml"
(* 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
@@ -13789,64 +14194,142 @@ end = struct
* 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. *)
+(**
+ {[
+ _open -> open
+ _in -> in
+ _MAX_LENGTH -> MAX_LENGTH
+ _Capital -> Capital
+
+ _open__ -> _open
+ open__ -> open
+
+ _'x -> 'x
+ _Capital__ -> _Capital
+ _MAX__ -> _MAX
+ __ -> __
+ __x -> __x
+ ___ -> _
+ ____ -> __
+ _ -> _ (* error *)
+
+ ]}
+ First we scan '__' from end to start,
+ If found, discard it.
+ Otherwise, check if it is [_ + keyword] or followed by capital letter,
+ If so, discard [_].
+ Limitations: user can not have [_Capital__, _Capital__other] to
+ make it all compile to [Capital].
+ Keyword is fine [open__, open__other].
+ So we loose polymorphism over capital letter.
+ It is okay, otherwise, if [_Captial__] is interpreted as [Capital], then
+ there is no way to express [_Capital]
+*)
+(* Copied from [ocaml/parsing/lexer.mll] *)
+let key_words = String_hash_set.of_array [|
+ "and";
+ "as";
+ "assert";
+ "begin";
+ "class";
+ "constraint";
+ "do";
+ "done";
+ "downto";
+ "else";
+ "end";
+ "exception";
+ "external";
+ "false";
+ "for";
+ "fun";
+ "function";
+ "functor";
+ "if";
+ "in";
+ "include";
+ "inherit";
+ "initializer";
+ "lazy";
+ "let";
+ "match";
+ "method";
+ "module";
+ "mutable";
+ "new";
+ "nonrec";
+ "object";
+ "of";
+ "open";
+ "or";
+(* "parser", PARSER; *)
+ "private";
+ "rec";
+ "sig";
+ "struct";
+ "then";
+ "to";
+ "true";
+ "try";
+ "type";
+ "val";
+ "virtual";
+ "when";
+ "while";
+ "with";
-external string_unsafe_set : string -> int -> char -> unit
- = "%string_unsafe_set"
-
-external string_create: int -> string = "caml_create_string"
-
-external unsafe_chr: int -> char = "%identity"
-
-(** {!Char.escaped} is locale sensitive in 4.02.3, fixed in the trunk,
- backport it here
- *)
-let escaped = function
- | '\'' -> "\\'"
- | '\\' -> "\\\\"
- | '\n' -> "\\n"
- | '\t' -> "\\t"
- | '\r' -> "\\r"
- | '\b' -> "\\b"
- | ' ' .. '~' as c ->
- let s = string_create 1 in
- string_unsafe_set s 0 c;
- s
- | c ->
- let n = Char.code c in
- let s = string_create 4 in
- string_unsafe_set s 0 '\\';
- string_unsafe_set s 1 (unsafe_chr (48 + n / 100));
- string_unsafe_set s 2 (unsafe_chr (48 + (n / 10) mod 10));
- string_unsafe_set s 3 (unsafe_chr (48 + n mod 10));
- s
-
+ "mod";
+ "land";
+ "lor";
+ "lxor";
+ "lsl";
+ "lsr";
+ "asr";
+|]
+let double_underscore = "__"
-let valid_hex x =
- match x with
- | '0' .. '9'
- | 'a' .. 'f'
- | 'A' .. 'F' -> true
- | _ -> false
+(*https://caml.inria.fr/pub/docs/manual-ocaml/lex.html
+{[
+ label-name ::= lowercase-ident
+]}
+*)
+let valid_start_char x =
+ match x with
+ | '_' | 'a' .. 'z' -> true
+ | _ -> false
+let translate ?loc name =
+ assert (not @@ Ext_string.is_empty name);
+ let i = Ext_string.rfind ~sub:double_underscore name in
+ if i < 0 then
+ let name_len = String.length name in
+ if name.[0] = '_' then begin
+ let try_key_word = (String.sub name 1 (name_len - 1)) in
+ if name_len > 1 &&
+ (not (valid_start_char try_key_word.[0])
+ || String_hash_set.mem key_words try_key_word) then
+ try_key_word
+ else
+ name
+ end
+ else name
+ else if i = 0 then name
+ else String.sub name 0 i
-let is_lower_case c =
- (c >= 'a' && c <= 'z')
- || (c >= '\224' && c <= '\246')
- || (c >= '\248' && c <= '\254')
end
-module Ast_utf8_string : sig
-#1 "ast_utf8_string.mli"
+module External_process : sig
+#1 "external_process.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -13872,26 +14355,39 @@ module Ast_utf8_string : sig
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-type error
-type exn += Error of int (* offset *) * error
-val pp_error : Format.formatter -> error -> unit
+(**
+ [handle_attributes_as_string
+ loc pval_name.txt pval_type pval_attributes pval_prim]
+ [pval_name.txt] is the name of identifier
+ [pval_prim] is the name of string literal
+
+ return value is of [pval_type, pval_prims, new_attrs]
+*)
+val handle_attributes_as_string :
+ Bs_loc.t ->
+ string ->
+ Ast_core_type.t ->
+ Ast_attributes.t ->
+ string ->
+ Ast_core_type.t * string list * Ast_attributes.t
+
+
-
-(* module Interp : sig *)
-(* val check_and_transform : int -> string -> int -> cxt -> unit *)
-(* val transform_test : string -> segments *)
-(* end *)
-val transform_test : string -> string
+(** [pval_prim_of_labels labels]
+ return [pval_prims] for FFI, it is specialized for
+ external object which is used in
+ {[ [%obj { x = 2; y = 1} ] ]}
+*)
+val pval_prim_of_labels : string Asttypes.loc list -> string list
-val transform : Location.t -> string -> string
end = struct
-#1 "ast_utf8_string.ml"
+#1 "external_process.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -13917,816 +14413,978 @@ end = struct
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-
-type error =
- | Invalid_code_point
- | Unterminated_backslash
- | Invalid_escape_code of char
- | Invalid_hex_escape
- | Invalid_unicode_escape
-
-let pp_error fmt err =
- Format.pp_print_string fmt @@ match err with
- | Invalid_code_point -> "Invalid code point"
- | Unterminated_backslash -> "\\ ended unexpectedly"
- | Invalid_escape_code c -> "Invalid escape code: " ^ String.make 1 c
- | Invalid_hex_escape ->
- "Invalid \\x escape"
- | Invalid_unicode_escape -> "Invalid \\u escape"
-
-
-
-type exn += Error of int (* offset *) * error
+[@@@ocaml.warning "+9"]
+let variant_can_bs_unwrap_fields row_fields =
+ let validity =
+ List.fold_left
+ begin fun st row ->
+ match st, row with
+ | (* we've seen no fields or only valid fields so far *)
+ (`No_fields | `Valid_fields),
+ (* and this field has one constructor arg that we can unwrap to *)
+ Parsetree.Rtag (label, attrs, false, ([ _ ]))
+ ->
+ `Valid_fields
+ | (* otherwise, this field or a previous field was invalid *)
+ _ ->
+ `Invalid_field
+ end
+ `No_fields
+ row_fields
+ in
+ match validity with
+ | `Valid_fields -> true
+ | `No_fields
+ | `Invalid_field -> false
-let error ~loc error =
- raise (Error (loc, error))
-(** Note the [loc] really should be the utf8-offset, it has nothing to do with our
- escaping mechanism
+(** Given the type of argument, process its [bs.] attribute and new type,
+ The new type is currently used to reconstruct the external type
+ and result type in [@@bs.obj]
+ They are not the same though, for example
+ {[
+ external f : hi:([ `hi | `lo ] [@bs.string]) -> unit -> _ = "" [@@bs.obj]
+ ]}
+ The result type would be [ hi:string ]
*)
-(* we can not just print new line in ES5
- seems we don't need
- escape "\b" "\f"
- we need escape "\n" "\r" since
- ocaml multiple-line allows [\n]
- visual input while es5 string
- does not*)
+let get_arg_type ~nolabel optional
+ (ptyp : Ast_core_type.t) :
+ External_arg_spec.attr * Ast_core_type.t =
+ let ptyp = if optional then Ast_core_type.extract_option_type_exn ptyp else ptyp in
+ if Ast_core_type.is_any ptyp then (* (_[@bs.as ])*)
+ if optional then
+ Bs_syntaxerr.err ptyp.ptyp_loc Invalid_underscore_type_in_external
+ else begin
+ let ptyp_attrs =
+ ptyp.Parsetree.ptyp_attributes
+ in
+ let result =
+ Ast_attributes.iter_process_bs_string_or_int_as ptyp_attrs
+ in
+ (* when ppx start dropping attributes
+ we should warn, there is a trade off whether
+ we should warn dropped non bs attribute or not
+ *)
+ Bs_ast_invariant.warn_unused_attributes ptyp_attrs;
+ match result with
+ | None ->
+ Bs_syntaxerr.err ptyp.ptyp_loc Invalid_underscore_type_in_external
-let rec check_and_transform (loc : int ) buf s byte_offset s_len =
- if byte_offset = s_len then ()
- else
- let current_char = s.[byte_offset] in
- match Ext_utf8.classify current_char with
- | Single 92 (* '\\' *) ->
- escape_code (loc + 1) buf s (byte_offset+1) s_len
- | Single 34 ->
- Buffer.add_string buf "\\\"";
- check_and_transform (loc + 1) buf s (byte_offset + 1) s_len
- | Single 39 ->
- Buffer.add_string buf "\\'";
- check_and_transform (loc + 1) buf s (byte_offset + 1) s_len
- | Single 10 ->
- Buffer.add_string buf "\\n";
- check_and_transform (loc + 1) buf s (byte_offset + 1) s_len
- | Single 13 ->
- Buffer.add_string buf "\\r";
- check_and_transform (loc + 1) buf s (byte_offset + 1) s_len
- | Single _ ->
- Buffer.add_char buf current_char;
- check_and_transform (loc + 1) buf s (byte_offset + 1) s_len
+ | Some (`Int i) ->
+ Arg_cst(External_arg_spec.cst_int i), Ast_literal.type_int ~loc:ptyp.ptyp_loc ()
+ | Some (`Str i)->
+ Arg_cst (External_arg_spec.cst_string i), Ast_literal.type_string ~loc:ptyp.ptyp_loc ()
+ | Some (`Json_str s) ->
+ Arg_cst (External_arg_spec.cst_json ptyp.ptyp_loc s),
+ Ast_literal.type_string ~loc:ptyp.ptyp_loc ()
- | Invalid
- | Cont _ -> error ~loc Invalid_code_point
- | Leading (n,_) ->
- let i' = Ext_utf8.next s ~remaining:n byte_offset in
- if i' < 0 then
- error ~loc Invalid_code_point
- else
- begin
- for k = byte_offset to i' do
- Buffer.add_char buf s.[k];
- done;
- check_and_transform (loc + 1 ) buf s (i' + 1) s_len
- end
-(* we share the same escape sequence with js *)
-and escape_code loc buf s offset s_len =
- if offset >= s_len then
- error ~loc Unterminated_backslash
- else
- Buffer.add_char buf '\\';
- let cur_char = s.[offset] in
- match cur_char with
- | '\\'
- | 'b'
- | 't'
- | 'n'
- | 'v'
- | 'f'
- | 'r'
- | '0'
- | '$'
- ->
- begin
- Buffer.add_char buf cur_char ;
- check_and_transform (loc + 1) buf s (offset + 1) s_len
- end
- | 'u' ->
- begin
- Buffer.add_char buf cur_char;
- unicode (loc + 1) buf s (offset + 1) s_len
- end
- | 'x' -> begin
- Buffer.add_char buf cur_char ;
- two_hex (loc + 1) buf s (offset + 1) s_len
end
- | _ -> error ~loc (Invalid_escape_code cur_char)
-and two_hex loc buf s offset s_len =
- if offset + 1 >= s_len then
- error ~loc Invalid_hex_escape;
- (*Location.raise_errorf ~loc "\\x need at least two chars";*)
- let a, b = s.[offset], s.[offset + 1] in
- if Ext_char.valid_hex a && Ext_char.valid_hex b then
- begin
- Buffer.add_char buf a ;
- Buffer.add_char buf b ;
- check_and_transform (loc + 2) buf s (offset + 2) s_len
- end
- else
- error ~loc Invalid_hex_escape
-(*Location.raise_errorf ~loc "%c%c is not a valid hex code" a b*)
+ else (* ([`a|`b] [@bs.string]) *)
+ let ptyp_desc = ptyp.ptyp_desc in
+ match Ast_attributes.process_bs_string_int_unwrap_uncurry ptyp.ptyp_attributes with
+ | (`String, ptyp_attributes)
+ ->
+ begin match ptyp_desc with
+ | Ptyp_variant ( row_fields, Closed, None)
+ ->
+ let attr =
+ Ast_polyvar.map_row_fields_into_strings ptyp.ptyp_loc row_fields in
+ attr,
+ {ptyp with
+ ptyp_attributes
+ }
+ | _ ->
+ Bs_syntaxerr.err ptyp.ptyp_loc Invalid_bs_string_type
+ end
+ | (`Ignore, ptyp_attributes) ->
+ (Ignore, {ptyp with ptyp_attributes})
+ | (`Int , ptyp_attributes) ->
+ begin match ptyp_desc with
+ | Ptyp_variant ( row_fields, Closed, None) ->
+ let int_lists =
+ Ast_polyvar.map_row_fields_into_ints ptyp.ptyp_loc row_fields in
+ Int int_lists ,
+ {ptyp with
+ ptyp_attributes
+ }
+ | _ -> Bs_syntaxerr.err ptyp.ptyp_loc Invalid_bs_int_type
+ end
+ | (`Unwrap, ptyp_attributes) ->
-and unicode loc buf s offset s_len =
- if offset + 3 >= s_len then
- error ~loc Invalid_unicode_escape
- (*Location.raise_errorf ~loc "\\u need at least four chars"*)
- ;
- let a0,a1,a2,a3 = s.[offset], s.[offset+1], s.[offset+2], s.[offset+3] in
- if
- Ext_char.valid_hex a0 &&
- Ext_char.valid_hex a1 &&
- Ext_char.valid_hex a2 &&
- Ext_char.valid_hex a3 then
- begin
- Buffer.add_char buf a0;
- Buffer.add_char buf a1;
- Buffer.add_char buf a2;
- Buffer.add_char buf a3;
- check_and_transform (loc + 4) buf s (offset + 4) s_len
- end
- else
- error ~loc Invalid_unicode_escape
-(*Location.raise_errorf ~loc "%c%c%c%c is not a valid unicode point"
- a0 a1 a2 a3 *)
-(* http://www.2ality.com/2015/01/es6-strings.html
- console.log('\uD83D\uDE80'); (* ES6*)
- console.log('\u{1F680}');
-*)
+ begin match ptyp_desc with
+ | (Ptyp_variant (row_fields, Closed, _) as ptyp_desc)
+ when variant_can_bs_unwrap_fields row_fields ->
+ Unwrap, {ptyp with ptyp_desc; ptyp_attributes}
+ | _ ->
+ Bs_syntaxerr.err ptyp.ptyp_loc Invalid_bs_unwrap_type
+ end
+ | (`Uncurry opt_arity, ptyp_attributes) ->
+ let real_arity = Ast_core_type.get_uncurry_arity ptyp in
+ (begin match opt_arity, real_arity with
+ | Some arity, `Not_function ->
+ Fn_uncurry_arity arity
+ | None, `Not_function ->
+ Bs_syntaxerr.err ptyp.ptyp_loc Canot_infer_arity_by_syntax
+ | None, `Arity arity ->
+ Fn_uncurry_arity arity
+ | Some arity, `Arity n ->
+ if n <> arity then
+ Bs_syntaxerr.err ptyp.ptyp_loc (Inconsistent_arity (arity,n))
+ else Fn_uncurry_arity arity
+ end, {ptyp with ptyp_attributes})
+ | (`Nothing, ptyp_attributes) ->
+ begin match ptyp_desc with
+ | Ptyp_constr ({txt = Lident "bool"; _}, [])
+ ->
+ Bs_warnings.prerr_bs_ffi_warning ptyp.ptyp_loc Unsafe_ffi_bool_type;
+ Nothing
+ | Ptyp_constr ({txt = Lident "unit"; _}, [])
+ -> if nolabel then Extern_unit else Nothing
+ | Ptyp_constr ({txt = Lident "array"; _}, [_])
+ -> Array
+ | Ptyp_variant _ ->
+ Bs_warnings.prerr_bs_ffi_warning ptyp.ptyp_loc Unsafe_poly_variant_type;
+ Nothing
+ | _ ->
+ Nothing
+ end, ptyp
+(**
+ [@@bs.module "react"]
+ [@@bs.module "react"]
+ ---
+ [@@bs.module "@" "react"]
+ [@@bs.module "@" "react"]
+ They should have the same module name
+ TODO: we should emit an warning if we bind
+ two external files to the same module name
+*)
+type bundle_source =
+ [`Nm_payload of string (* from payload [@@bs.val "xx" ]*)
+ |`Nm_external of string (* from "" in external *)
+ | `Nm_val of string (* from function name *)
+ ]
+let string_of_bundle_source (x : bundle_source) =
+ match x with
+ | `Nm_payload x
+ | `Nm_external x
+ | `Nm_val x -> x
+type name_source =
+ [ bundle_source
+ | `Nm_na
+ ]
-let transform_test s =
- let s_len = String.length s in
- let buf = Buffer.create (s_len * 2) in
- check_and_transform 0 buf s 0 s_len;
- Buffer.contents buf
-let transform loc s =
- let s_len = String.length s in
- let buf = Buffer.create (s_len * 2) in
- try
- check_and_transform 0 buf s 0 s_len;
- Buffer.contents buf
- with
- Error (offset, error)
- -> Location.raise_errorf ~loc "Offset: %d, %a" offset pp_error error
+type st =
+ { val_name : name_source;
+ external_module_name : External_ffi_types.external_module_name option;
+ module_as_val : External_ffi_types.external_module_name option;
+ val_send : name_source ;
+ val_send_pipe : Ast_core_type.t option;
+ splice : bool ; (* mutable *)
+ scopes : string list ;
+ set_index : bool; (* mutable *)
+ get_index : bool;
+ new_name : name_source ;
+ call_name : name_source ;
+ set_name : name_source ;
+ get_name : name_source ;
-end
-module Bs_loc : sig
-#1 "bs_loc.mli"
-(* 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. *)
+ mk_obj : bool ;
+ return_wrapper : External_ffi_types.return_wrapper ;
-type t = Location.t = {
- loc_start : Lexing.position;
- loc_end : Lexing.position ;
- loc_ghost : bool
-}
+ }
-val is_ghost : t -> bool
-val merge : t -> t -> t
-val none : t
+let init_st =
+ {
+ val_name = `Nm_na;
+ external_module_name = None ;
+ module_as_val = None;
+ val_send = `Nm_na;
+ val_send_pipe = None;
+ splice = false;
+ scopes = [];
+ set_index = false;
+ get_index = false;
+ new_name = `Nm_na;
+ call_name = `Nm_na;
+ set_name = `Nm_na ;
+ get_name = `Nm_na ;
+ mk_obj = false ;
+ return_wrapper = Return_unset;
+ }
-end = struct
-#1 "bs_loc.ml"
-(* 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 = Location.t = {
- loc_start : Lexing.position;
- loc_end : Lexing.position ;
- loc_ghost : bool
-}
-let is_ghost x = x.loc_ghost
-let merge (l: t) (r : t) =
- if is_ghost l then r
- else if is_ghost r then l
- else match l,r with
- | {loc_start ; }, {loc_end; _} (* TODO: improve*)
- ->
- {loc_start ;loc_end; loc_ghost = false}
+let process_external_attributes
+ no_arguments
+ (prim_name_or_pval_prim: [< bundle_source ] as 'a)
+ pval_prim
+ (prim_attributes : Ast_attributes.t) : _ * Ast_attributes.t =
-let none = Location.none
+ (* shared by `[@@bs.val]`, `[@@bs.send]`,
+ `[@@bs.set]`, `[@@bs.get]` , `[@@bs.new]`
+ `[@@bs.send.pipe]` does not use it
+ *)
+ let name_from_payload_or_prim ~loc (payload : Parsetree.payload) : name_source =
+ match payload with
+ | PStr [] ->
+ (prim_name_or_pval_prim :> name_source)
+ (* It is okay to have [@@bs.val] without payload *)
+ | _ ->
+ begin match Ast_payload.is_single_string payload with
+ | Some (val_name, _) -> `Nm_payload val_name
+ | None ->
+ Location.raise_errorf ~loc "Invalid payload"
+ end
-end
-module Ast_utf8_string_interp : sig
-#1 "ast_utf8_string_interp.mli"
-(* 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. *)
+ in
+ List.fold_left
+ (fun (st, attrs)
+ (({txt ; loc}, payload) as attr : Ast_attributes.attr)
+ ->
+ if Ext_string.starts_with txt "bs." then
+ begin match txt with
+ | "bs.val" ->
+ if no_arguments then
+ {st with val_name = name_from_payload_or_prim ~loc payload}
+ else
+ {st with call_name = name_from_payload_or_prim ~loc payload}
+
+ | "bs.module" ->
+ begin match Ast_payload.assert_strings loc payload with
+ | [bundle] ->
+ {st with external_module_name =
+ Some {bundle; module_bind_name = Phint_nothing}}
+ | [bundle;bind_name] ->
+ {st with external_module_name =
+ Some {bundle; module_bind_name = Phint_name bind_name}}
+ | [] ->
+ { st with
+ module_as_val =
+ Some
+ { bundle =
+ string_of_bundle_source
+ (prim_name_or_pval_prim :> bundle_source) ;
+ module_bind_name = Phint_nothing}
+ }
+ | _ ->
+ Bs_syntaxerr.err loc Illegal_attribute
+ end
+ | "bs.scope" ->
+ begin match Ast_payload.assert_strings loc payload with
+ | [] ->
+ Bs_syntaxerr.err loc Illegal_attribute
+ (* We need err on empty scope, so we can tell the difference
+ between unset/set
+ *)
+ | scopes -> { st with scopes = scopes }
+ end
+ | "bs.splice" -> {st with splice = true}
+ | "bs.send" ->
+ { st with val_send = name_from_payload_or_prim ~loc payload}
+ | "bs.send.pipe"
+ ->
+ { st with val_send_pipe = Some (Ast_payload.as_core_type loc payload)}
+ | "bs.set" ->
+ {st with set_name = name_from_payload_or_prim ~loc payload}
+ | "bs.get" -> {st with get_name = name_from_payload_or_prim ~loc payload}
+ | "bs.new" -> {st with new_name = name_from_payload_or_prim ~loc payload}
+ | "bs.set_index" -> {st with set_index = true}
+ | "bs.get_index"-> {st with get_index = true}
+ | "bs.obj" -> {st with mk_obj = true}
+ | "bs.return" ->
+ let aux loc txt : External_ffi_types.return_wrapper =
+ begin match txt with
+ | "undefined_to_opt" -> Return_undefined_to_opt
+ | "null_to_opt" -> Return_null_to_opt
+ | "nullable"
+ | "null_undefined_to_opt" -> Return_null_undefined_to_opt
+ | "identity" -> Return_identity
+ | _ ->
+ Bs_syntaxerr.err loc Not_supported_directive_in_bs_return
+ end in
+ let actions =
+ Ast_payload.ident_or_record_as_config loc payload
+ in
+ begin match actions with
+ | [ ({txt; _ },None) ] ->
+ { st with return_wrapper = aux loc txt}
+ | _ ->
+ Bs_syntaxerr.err loc Not_supported_directive_in_bs_return
+ end
+ | _ -> (Location.prerr_warning loc (Bs_unused_attribute txt); st)
+ end, attrs
+ else (st , attr :: attrs)
+ )
+ (init_st, []) prim_attributes
-type kind =
- | String
- | Var
-type error = private
- | Invalid_code_point
- | Unterminated_backslash
- | Invalid_escape_code of char
- | Invalid_hex_escape
- | Invalid_unicode_escape
- | Unterminated_variable
- | Unmatched_paren
- | Invalid_syntax_of_var of string
-(** Note the position is about code point *)
-type pos = { lnum : int ; offset : int ; byte_bol : int }
+let rec has_bs_uncurry (attrs : Ast_attributes.t) =
+ match attrs with
+ | ({txt = "bs.uncurry"; _ }, _) :: attrs ->
+ true
+ | _ :: attrs -> has_bs_uncurry attrs
+ | [] -> false
-type segment = {
- start : pos;
- finish : pos ;
- kind : kind;
- content : string ;
-}
-type segments = segment list
+let check_return_wrapper
+ loc (wrapper : External_ffi_types.return_wrapper)
+ result_type =
+ match wrapper with
+ | Return_identity -> wrapper
+ | Return_unset ->
+ if Ast_core_type.is_unit result_type then
+ Return_replaced_with_unit
+ else if Ast_core_type.is_user_bool result_type then
+ Return_to_ocaml_bool
+ else
+ wrapper
+ | Return_undefined_to_opt
+ | Return_null_to_opt
+ | Return_null_undefined_to_opt
+ ->
+ if Ast_core_type.is_user_option result_type then
+ wrapper
+ else
+ Bs_syntaxerr.err loc Expect_opt_in_bs_return_to_opt
+ | Return_replaced_with_unit
+ | Return_to_ocaml_bool ->
+ assert false (* Not going to happen from user input*)
-type cxt = {
- mutable segment_start : pos ;
- buf : Buffer.t ;
- s_len : int ;
- mutable segments : segments;
- mutable pos_bol : int; (* record the abs position of current beginning line *)
- mutable byte_bol : int ;
- mutable pos_lnum : int ; (* record the line number *)
-}
-type exn += Error of pos * pos * error
-val empty_segment : segment -> bool
-val transform_test : string -> segment list
-val transform_interp : Location.t -> string -> Parsetree.expression
+(** Note that the passed [type_annotation] is already processed by visitor pattern before
+*)
+let handle_attributes
+ (loc : Bs_loc.t)
+ (pval_prim : string )
+ (type_annotation : Parsetree.core_type)
+ (prim_attributes : Ast_attributes.t) (prim_name : string)
+ : Ast_core_type.t * string * External_ffi_types.t * Ast_attributes.t =
+ (** sanity check here
+ {[ int -> int -> (int -> int -> int [@bs.uncurry])]}
+ It does not make sense
+ *)
+ if has_bs_uncurry type_annotation.Parsetree.ptyp_attributes then
+ begin
+ Location.raise_errorf
+ ~loc "[@@bs.uncurry] can not be applied to the whole definition"
+ end;
-end = struct
-#1 "ast_utf8_string_interp.ml"
-(* 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 prim_name_or_pval_prim =
+ if String.length prim_name = 0 then `Nm_val pval_prim
+ else `Nm_external prim_name (* need check name *)
+ in
+ let result_type, arg_types_ty =
+ Ast_core_type.list_of_arrow type_annotation in
+ if has_bs_uncurry result_type.ptyp_attributes then
+ begin
+ Location.raise_errorf
+ ~loc:result_type.ptyp_loc
+ "[@@bs.uncurry] can not be applied to tailed position"
+ end ;
+ let (st, left_attrs) =
+ process_external_attributes
+ (arg_types_ty = [])
+ prim_name_or_pval_prim pval_prim prim_attributes in
-type error =
- | Invalid_code_point
- | Unterminated_backslash
- | Invalid_escape_code of char
- | Invalid_hex_escape
- | Invalid_unicode_escape
- | Unterminated_variable
- | Unmatched_paren
- | Invalid_syntax_of_var of string
-type kind =
- | String
- | Var
+ if st.mk_obj then
+ begin match st with
+ | {
+ val_name = `Nm_na;
+ external_module_name = None ;
+ module_as_val = None;
+ val_send = `Nm_na;
+ val_send_pipe = None;
+ splice = false;
+ new_name = `Nm_na;
+ call_name = `Nm_na;
+ set_name = `Nm_na ;
+ get_name = `Nm_na ;
+ get_index = false ;
+ return_wrapper = Return_unset ;
+ set_index = false ;
+ mk_obj = _;
+ scopes = [];
+ (* wrapper does not work with [bs.obj]
+ TODO: better error message *)
+ } ->
+ if String.length prim_name <> 0 then
+ Location.raise_errorf ~loc "[@@bs.obj] expect external names to be empty string";
+ let arg_kinds, new_arg_types_ty, result_types =
+ Ext_list.fold_right
+ (fun (label,ty,attr,loc) ( arg_labels, arg_types, result_types) ->
+ let arg_label = Ast_core_type.label_name label in
+ let new_arg_label, new_arg_types, output_tys =
+ match arg_label with
+ | Empty ->
+ let arg_type, new_ty = get_arg_type ~nolabel:true false ty in
+ begin match arg_type with
+ | Extern_unit ->
+ External_arg_spec.empty_kind arg_type, (label,new_ty,attr,loc)::arg_types, result_types
+ | _ ->
+ Location.raise_errorf ~loc "expect label, optional, or unit here"
+ end
+ | Label name ->
+ let arg_type, new_ty = get_arg_type ~nolabel:false false ty in
+ begin match arg_type with
+ | Ignore ->
+ External_arg_spec.empty_kind arg_type,
+ (label,new_ty,attr,loc)::arg_types, result_types
+ | Arg_cst i ->
+ let s = (Lam_methname.translate ~loc name) in
+ {arg_label = External_arg_spec.label s (Some i);
+ arg_type },
+ arg_types, (* ignored in [arg_types], reserved in [result_types] *)
+ ((name , [], new_ty) :: result_types)
+ | Nothing | Array ->
+ let s = (Lam_methname.translate ~loc name) in
+ {arg_label = External_arg_spec.label s None ; arg_type },
+ (label,new_ty,attr,loc)::arg_types,
+ ((name , [], new_ty) :: result_types)
+ | Int _ ->
+ let s = Lam_methname.translate ~loc name in
+ {arg_label = External_arg_spec.label s None; arg_type},
+ (label,new_ty,attr,loc)::arg_types,
+ ((name, [], Ast_literal.type_int ~loc ()) :: result_types)
+ | NullString _ ->
+ let s = Lam_methname.translate ~loc name in
+ {arg_label = External_arg_spec.label s None; arg_type},
+ (label,new_ty,attr,loc)::arg_types,
+ ((name, [], Ast_literal.type_string ~loc ()) :: result_types)
+ | Fn_uncurry_arity _ ->
+ Location.raise_errorf ~loc
+ "The combination of [@@bs.obj], [@@bs.uncurry] is not supported yet"
+ | Extern_unit -> assert false
+ | NonNullString _
+ ->
+ Location.raise_errorf ~loc
+ "bs.obj label %s does not support such arg type" name
+ | Unwrap ->
+ Location.raise_errorf ~loc
+ "bs.obj label %s does not support [@bs.unwrap] arguments" name
+ end
+ | Optional name ->
+ let arg_type, new_ty_extract = get_arg_type ~nolabel:false true ty in
+ let new_ty = Ast_core_type.lift_option_type new_ty_extract in
+ begin match arg_type with
+ | Ignore ->
+ External_arg_spec.empty_kind arg_type,
+ (label,new_ty,attr,loc)::arg_types, result_types
-(** Note the position is about code point *)
-type pos = {
- lnum : int ;
- offset : int ;
- byte_bol : int (* Note it actually needs to be in sync with OCaml's lexing semantics *)
-}
+ | Nothing | Array ->
+ let s = (Lam_methname.translate ~loc name) in
+ {arg_label = External_arg_spec.optional s; arg_type},
+ (label,new_ty,attr,loc)::arg_types,
+ ( (name, [], Ast_comb.to_undefined_type loc new_ty_extract) :: result_types)
+ | Int _ ->
+ let s = Lam_methname.translate ~loc name in
+ {arg_label = External_arg_spec.optional s ; arg_type },
+ (label,new_ty,attr,loc)::arg_types,
+ ((name, [], Ast_comb.to_undefined_type loc @@ Ast_literal.type_int ~loc ()) :: result_types)
+ | NullString _ ->
+ let s = Lam_methname.translate ~loc name in
+ {arg_label = External_arg_spec.optional s ; arg_type },
+ (label,new_ty,attr,loc)::arg_types,
+ ((name, [], Ast_comb.to_undefined_type loc @@ Ast_literal.type_string ~loc ()) :: result_types)
+ | Arg_cst _
+ ->
+ Location.raise_errorf ~loc "bs.as is not supported with optional yet"
+ | Fn_uncurry_arity _ ->
+ Location.raise_errorf ~loc
+ "The combination of [@@bs.obj], [@@bs.uncurry] is not supported yet"
+ | Extern_unit -> assert false
+ | NonNullString _
+ ->
+ Location.raise_errorf ~loc
+ "bs.obj label %s does not support such arg type" name
+ | Unwrap ->
+ Location.raise_errorf ~loc
+ "bs.obj label %s does not support [@bs.unwrap] arguments" name
+ end
+ in
+ (
+ new_arg_label::arg_labels,
+ new_arg_types,
+ output_tys)) arg_types_ty
+ ( [], [], []) in
+ let result =
+ if Ast_core_type.is_any result_type then
+ Ast_core_type.make_obj ~loc result_types
+ else
+ snd @@ get_arg_type ~nolabel:true false result_type (* result type can not be labeled *)
-type segment = {
- start : pos;
- finish : pos ;
- kind : kind;
- content : string ;
-}
+ in
+ begin
+ (
+ Ext_list.fold_right (fun (label,ty,attrs,loc) acc ->
+ Ast_helper.Typ.arrow ~loc ~attrs label ty acc
+ ) new_arg_types_ty result
+ ) ,
+ prim_name,
+ Ffi_obj_create arg_kinds,
+ left_attrs
+ end
-type segments = segment list
+ | _ -> Location.raise_errorf ~loc "Attribute found that conflicts with [@@bs.obj]"
+ end
-type cxt = {
- mutable segment_start : pos ;
- buf : Buffer.t ;
- s_len : int ;
- mutable segments : segments;
- mutable pos_bol : int; (* record the abs position of current beginning line *)
- mutable byte_bol : int ;
- mutable pos_lnum : int ; (* record the line number *)
-}
+ else
+ let splice = st.splice in
+ let arg_type_specs, new_arg_types_ty, arg_type_specs_length =
+ Ext_list.fold_right
+ (fun (label,ty,attr,loc) (arg_type_specs, arg_types, i) ->
+ let arg_label = Ast_core_type.label_name label in
+ let arg_label, arg_type, new_arg_types =
+ match arg_label with
+ | Optional s ->
+ let arg_type , new_ty = get_arg_type ~nolabel:false true ty in
+ begin match arg_type with
+ | NonNullString _ ->
+ (* ?x:([`x of int ] [@bs.string]) does not make sense *)
+ Location.raise_errorf
+ ~loc
+ "[@@bs.string] does not work with optional when it has arities in label %s" label
+ | _ ->
+ External_arg_spec.optional s, arg_type,
+ ((label, Ast_core_type.lift_option_type new_ty , attr,loc) :: arg_types) end
+ | Label s ->
+ begin match get_arg_type ~nolabel:false false ty with
+ | (Arg_cst ( i) as arg_type), new_ty ->
+ External_arg_spec.label s (Some i), arg_type, arg_types
+ | arg_type, new_ty ->
+ External_arg_spec.label s None, arg_type, (label, new_ty,attr,loc) :: arg_types
+ end
+ | Empty ->
+ begin match get_arg_type ~nolabel:true false ty with
+ | (Arg_cst ( i) as arg_type), new_ty ->
+ External_arg_spec.empty_lit i , arg_type, arg_types
+ | arg_type, new_ty ->
+ External_arg_spec.empty_label, arg_type, (label, new_ty,attr,loc) :: arg_types
+ end
+ in
+ (if i = 0 && splice then
+ match arg_type with
+ | Array -> ()
+ | _ -> Location.raise_errorf ~loc "[@@@@bs.splice] expect the last type to be an array");
+ ({ External_arg_spec.arg_label ;
+ arg_type
+ } :: arg_type_specs,
+ new_arg_types,
+ if arg_type = Ignore then i
+ else i + 1
+ )
+ ) arg_types_ty
+ (match st with
+ | {val_send_pipe = Some obj; _ } ->
+ let arg_type, new_ty = get_arg_type ~nolabel:true false obj in
+ begin match arg_type with
+ | Arg_cst _ ->
+ Location.raise_errorf ~loc:obj.ptyp_loc "[@bs.as] is not supported in bs.send type "
+ | _ ->
+ (* more error checking *)
+ [External_arg_spec.empty_kind arg_type]
+ ,
+ ["", new_ty, [], obj.ptyp_loc]
+ ,0
+ end
-type exn += Error of pos * pos * error
+ | {val_send_pipe = None ; _ } -> [],[], 0) in
-let pp_error fmt err =
- Format.pp_print_string fmt @@ match err with
- | Invalid_code_point -> "Invalid code point"
- | Unterminated_backslash -> "\\ ended unexpectedly"
- | Invalid_escape_code c -> "Invalid escape code: " ^ String.make 1 c
- | Invalid_hex_escape ->
- "Invalid \\x escape"
- | Invalid_unicode_escape -> "Invalid \\u escape"
- | Unterminated_variable -> "$ unterminated"
- | Unmatched_paren -> "Unmatched paren"
- | Invalid_syntax_of_var s -> "`" ^s ^ "' is not a valid syntax of interpolated identifer"
-let valid_lead_identifier_char x =
- match x with
- | 'a'..'z' | '_' -> true
- | _ -> false
+ let ffi : External_ffi_types.attr = match st with
+ | {set_index = true;
-let valid_identifier_char x =
- match x with
- | 'a'..'z'
- | 'A'..'Z'
- | '0'..'9'
- | '_' | '\''-> true
- | _ -> false
-(** Invariant: [valid_lead_identifier] has to be [valid_identifier] *)
+ val_name = `Nm_na;
+ external_module_name = None ;
+ module_as_val = None;
+ val_send = `Nm_na;
+ val_send_pipe = None;
+ splice = false;
+ scopes ;
+ get_index = false;
+ new_name = `Nm_na;
+ call_name = `Nm_na;
+ set_name = `Nm_na ;
+ get_name = `Nm_na ;
-let valid_identifier s =
- let s_len = String.length s in
- if s_len = 0 then false
- else
- valid_lead_identifier_char s.[0] &&
- Ext_string.for_all_from s 1 valid_identifier_char
+ return_wrapper = _;
+ mk_obj = _ ;
-
-let is_space x =
- match x with
- | ' ' | '\n' | '\t' -> true
- | _ -> false
+ }
+ ->
+ if String.length prim_name <> 0 then
+ Location.raise_errorf ~loc "[@@bs.set_index] expect external names to be empty string";
+ if arg_type_specs_length = 3 then
+ Js_set_index {js_set_index_scopes = scopes}
+ else
+ Location.raise_errorf ~loc "Ill defined attribute [@@bs.set_index](arity of 3)"
+ | {set_index = true; _}
+ ->
+ Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.set_index]")
-(**
- FIXME: multiple line offset
- if there is no line offset. Note {|{j||} border will never trigger a new line
-*)
-let update_position border
- ({lnum ; offset;byte_bol } : pos)
- (pos : Lexing.position)=
- if lnum = 0 then
- {pos with pos_cnum = pos.pos_cnum + border + offset }
- (** When no newline, the column number is [border + offset] *)
- else
- {
- pos with
- pos_lnum = pos.pos_lnum + lnum ;
- pos_bol = pos.pos_cnum + border + byte_bol;
- pos_cnum = pos.pos_cnum + border + byte_bol + offset;
- (** when newline, the column number is [offset] *)
- }
-let update border
- (start : pos)
- (finish : pos) (loc : Location.t) : Location.t =
- let start_pos = loc.loc_start in
- { loc with
- loc_start =
- update_position border start start_pos;
- loc_end =
- update_position border finish start_pos
- }
+ | {get_index = true;
+ val_name = `Nm_na;
+ external_module_name = None ;
+ module_as_val = None;
+ val_send = `Nm_na;
+ val_send_pipe = None;
-(** Note [Var] kind can not be mpty *)
-let empty_segment {content } =
- Ext_string.is_empty content
+ splice = false;
+ scopes ;
+ new_name = `Nm_na;
+ call_name = `Nm_na;
+ set_name = `Nm_na ;
+ get_name = `Nm_na ;
+ set_index = false;
+ mk_obj;
+ return_wrapper ;
+ } ->
+ if String.length prim_name <> 0 then
+ Location.raise_errorf ~loc "[@@bs.get_index] expect external names to be empty string";
+ if arg_type_specs_length = 2 then
+ Js_get_index {js_get_index_scopes = scopes}
+ else Location.raise_errorf ~loc
+ "Ill defined attribute [@@bs.get_index] (arity expected 2 : while %d)" arg_type_specs_length
+ | {get_index = true; _}
+ ->
+ Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.get_index]")
-let update_newline ~byte_bol loc cxt =
- cxt.pos_lnum <- cxt.pos_lnum + 1 ;
- cxt.pos_bol <- loc;
- cxt.byte_bol <- byte_bol
-let pos_error cxt ~loc error =
- raise (Error
- (cxt.segment_start,
- { lnum = cxt.pos_lnum ; offset = loc - cxt.pos_bol ; byte_bol = cxt.byte_bol}, error))
-let add_var_segment cxt loc =
- let content = Buffer.contents cxt.buf in
- Buffer.clear cxt.buf ;
- let next_loc = {
- lnum = cxt.pos_lnum ; offset = loc - cxt.pos_bol ;
- byte_bol = cxt.byte_bol } in
- if valid_identifier content then
- begin
- cxt.segments <-
- { start = cxt.segment_start;
- finish = next_loc ;
- kind = Var;
- content} :: cxt.segments ;
- cxt.segment_start <- next_loc
- end
- else pos_error cxt ~loc (Invalid_syntax_of_var content)
-let add_str_segment cxt loc =
- let content = Buffer.contents cxt.buf in
- Buffer.clear cxt.buf ;
- let next_loc = {
- lnum = cxt.pos_lnum ; offset = loc - cxt.pos_bol ;
- byte_bol = cxt.byte_bol } in
- cxt.segments <-
- { start = cxt.segment_start;
- finish = next_loc ;
- kind = String;
- content} :: cxt.segments ;
- cxt.segment_start <- next_loc
+ | {module_as_val = Some external_module_name ;
+ get_index = false;
+ val_name ;
+ new_name ;
-
+ external_module_name = None ;
+ val_send = `Nm_na;
+ val_send_pipe = None;
+ scopes = []; (* module as var does not need scopes *)
+ splice;
+ call_name = `Nm_na;
+ set_name = `Nm_na ;
+ get_name = `Nm_na ;
+ set_index = false;
+ return_wrapper = _;
+ mk_obj = _ ;
+ } ->
+ begin match arg_types_ty, new_name, val_name with
+ | [], `Nm_na, _ -> Js_module_as_var external_module_name
+ | _, `Nm_na, _ -> Js_module_as_fn {splice; external_module_name }
+ | _, #bundle_source, #bundle_source ->
+ Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.module].")
+ | _, (`Nm_val _ | `Nm_external _) , `Nm_na
+ -> Js_module_as_class external_module_name
+ | _, `Nm_payload _ , `Nm_na
+ ->
+ Location.raise_errorf ~loc
+ "Incorrect FFI attribute found: (bs.new should not carry a payload here)"
+ end
+ | {module_as_val = Some x; _}
+ ->
+ Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.module].")
-let rec check_and_transform (loc : int ) s byte_offset ({s_len; buf} as cxt : cxt) =
- if byte_offset = s_len then
- add_str_segment cxt loc
- else
- let current_char = s.[byte_offset] in
- match Ext_utf8.classify current_char with
- | Single 92 (* '\\' *) ->
- escape_code (loc + 1) s (byte_offset+1) cxt
- | Single 34 ->
- Buffer.add_string buf "\\\"";
- check_and_transform (loc + 1) s (byte_offset + 1) cxt
- | Single 39 ->
- Buffer.add_string buf "\\'";
- check_and_transform (loc + 1) s (byte_offset + 1) cxt
- | Single 10 ->
+ | {call_name = (`Nm_val name | `Nm_external name | `Nm_payload name) ;
+ splice;
+ scopes ;
+ external_module_name;
- Buffer.add_string buf "\\n";
- let loc = loc + 1 in
- let byte_offset = byte_offset + 1 in
- update_newline ~byte_bol:byte_offset loc cxt ; (* Note variable could not have new-line *)
- check_and_transform loc s byte_offset cxt
- | Single 13 ->
- Buffer.add_string buf "\\r";
- check_and_transform (loc + 1) s (byte_offset + 1) cxt
- | Single 36 -> (* $ *)
- add_str_segment cxt loc ;
- let offset = byte_offset + 1 in
- if offset >= s_len then
- pos_error ~loc cxt Unterminated_variable
- else
- let cur_char = s.[offset] in
- if cur_char = '(' then
- expect_var_paren (loc + 2) s (offset + 1) cxt
- else
- expect_simple_var (loc + 1) s offset cxt
- | Single _ ->
- Buffer.add_char buf current_char;
- check_and_transform (loc + 1) s (byte_offset + 1) cxt
+ val_name = `Nm_na ;
+ module_as_val = None;
+ val_send = `Nm_na ;
+ val_send_pipe = None;
- | Invalid
- | Cont _ -> pos_error ~loc cxt Invalid_code_point
- | Leading (n,_) ->
- let i' = Ext_utf8.next s ~remaining:n byte_offset in
- if i' < 0 then
- pos_error cxt ~loc Invalid_code_point
- else
- begin
- for k = byte_offset to i' do
- Buffer.add_char buf s.[k];
- done;
- check_and_transform (loc + 1 ) s (i' + 1) cxt
- end
-(**Lets keep identifier simple, so that we could generating a function easier in the future
- for example
- let f = [%fn{| $x + $y = $x_add_y |}]
-*)
-and expect_simple_var loc s offset ({buf; s_len} as cxt) =
- let v = ref offset in
- (* prerr_endline @@ Ext_pervasives.dump (s, has_paren, (is_space s.[!v]), !v); *)
- if not (offset < s_len && valid_lead_identifier_char s.[offset]) then
- pos_error cxt ~loc (Invalid_syntax_of_var Ext_string.empty)
- else
- begin
- while !v < s_len && valid_identifier_char s.[!v] do (* TODO*)
- let cur_char = s.[!v] in
- Buffer.add_char buf cur_char;
- incr v ;
- done;
- let added_length = !v - offset in
- let loc = added_length + loc in
- add_var_segment cxt loc ;
- check_and_transform loc s (added_length + offset) cxt
- end
-and expect_var_paren loc s offset ({buf; s_len} as cxt) =
- let v = ref offset in
- (* prerr_endline @@ Ext_pervasives.dump (s, has_paren, (is_space s.[!v]), !v); *)
- while !v < s_len && s.[!v] <> ')' do
- let cur_char = s.[!v] in
- Buffer.add_char buf cur_char;
- incr v ;
- done;
- let added_length = !v - offset in
- let loc = added_length + 1 + loc in
- if !v < s_len && s.[!v] = ')' then
- begin
- add_var_segment cxt loc ;
- check_and_transform loc s (added_length + 1 + offset) cxt
- end
- else
- pos_error cxt ~loc Unmatched_paren
+ set_index = false;
+ get_index = false;
+ new_name = `Nm_na;
+ set_name = `Nm_na ;
+ get_name = `Nm_na ;
+ mk_obj = _ ;
+ return_wrapper = _ ;
+ } ->
+ Js_call {splice; name; external_module_name; scopes }
+ | {call_name = #bundle_source ; _ }
+ ->
+ Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.val]")
+ | {val_name = (`Nm_val name | `Nm_external name | `Nm_payload name);
+ external_module_name;
+ call_name = `Nm_na ;
+ module_as_val = None;
+ val_send = `Nm_na ;
+ val_send_pipe = None;
+ set_index = false;
+ get_index = false;
+ new_name = `Nm_na;
+ set_name = `Nm_na ;
+ get_name = `Nm_na;
+ mk_obj = _;
+ return_wrapper = _;
+ splice = false ;
+ scopes ;
+ }
+ ->
+ Js_global { name; external_module_name; scopes}
+ | {val_name = #bundle_source ; _ }
+ ->
+ Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.val]")
+ | {splice ;
+ scopes ;
+ external_module_name = (Some _ as external_module_name);
-(* we share the same escape sequence with js *)
-and escape_code loc s offset ({ buf; s_len} as cxt) =
- if offset >= s_len then
- pos_error cxt ~loc Unterminated_backslash
- else
- Buffer.add_char buf '\\';
- let cur_char = s.[offset] in
- match cur_char with
- | '\\'
- | 'b'
- | 't'
- | 'n'
- | 'v'
- | 'f'
- | 'r'
- | '0'
- | '$'
- ->
- begin
- Buffer.add_char buf cur_char ;
- check_and_transform (loc + 1) s (offset + 1) cxt
- end
- | 'u' ->
- begin
- Buffer.add_char buf cur_char;
- unicode (loc + 1) s (offset + 1) cxt
- end
- | 'x' -> begin
- Buffer.add_char buf cur_char ;
- two_hex (loc + 1) s (offset + 1) cxt
- end
- | _ -> pos_error cxt ~loc (Invalid_escape_code cur_char)
-and two_hex loc s offset ({buf ; s_len} as cxt) =
- if offset + 1 >= s_len then
- pos_error cxt ~loc Invalid_hex_escape;
- let a, b = s.[offset], s.[offset + 1] in
- if Ext_char.valid_hex a && Ext_char.valid_hex b then
- begin
- Buffer.add_char buf a ;
- Buffer.add_char buf b ;
- check_and_transform (loc + 2) s (offset + 2) cxt
- end
- else
- pos_error cxt ~loc Invalid_hex_escape
+ val_name = `Nm_na ;
+ call_name = `Nm_na ;
+ module_as_val = None;
+ val_send = `Nm_na ;
+ val_send_pipe = None;
+ set_index = false;
+ get_index = false;
+ new_name = `Nm_na;
+ set_name = `Nm_na ;
+ get_name = `Nm_na ;
+ mk_obj = _ ;
+ return_wrapper= _ ;
+ }
+ ->
+ let name = string_of_bundle_source prim_name_or_pval_prim in
+ if arg_type_specs_length = 0 then
+ Js_global { name; external_module_name; scopes}
+ else Js_call {splice; name; external_module_name; scopes}
+ | {val_send = (`Nm_val name | `Nm_external name | `Nm_payload name);
+ splice;
+ scopes;
+ val_send_pipe = None;
+ val_name = `Nm_na ;
+ call_name = `Nm_na ;
+ module_as_val = None;
+ set_index = false;
+ get_index = false;
+ new_name = `Nm_na;
+ set_name = `Nm_na ;
+ get_name = `Nm_na ;
+ external_module_name = None ;
+ mk_obj = _ ;
+ return_wrapper = _ ;
+ } ->
+ (* PR #2162 - since when we assemble arguments the first argument in
+ [@@bs.send] is ignored
+ *)
+ begin match arg_type_specs with
+ | [] ->
+ Location.raise_errorf
+ ~loc "Ill defined attribute [@@bs.send] (at least one argument)"
+ | {arg_type = Arg_cst _ ; arg_label = _} :: _
+ ->
+ Location.raise_errorf
+ ~loc "Ill defined attribute [@@bs.send] (first argument can not be const)"
+ | _ :: _ ->
+ Js_send {splice ; name; js_send_scopes = scopes ; pipe = false}
+ end
-and unicode loc s offset ({buf ; s_len} as cxt) =
- if offset + 3 >= s_len then
- pos_error cxt ~loc Invalid_unicode_escape
- ;
- let a0,a1,a2,a3 = s.[offset], s.[offset+1], s.[offset+2], s.[offset+3] in
- if
- Ext_char.valid_hex a0 &&
- Ext_char.valid_hex a1 &&
- Ext_char.valid_hex a2 &&
- Ext_char.valid_hex a3 then
- begin
- Buffer.add_char buf a0;
- Buffer.add_char buf a1;
- Buffer.add_char buf a2;
- Buffer.add_char buf a3;
- check_and_transform (loc + 4) s (offset + 4) cxt
- end
- else
- pos_error cxt ~loc Invalid_unicode_escape
-let transform_test s =
- let s_len = String.length s in
- let buf = Buffer.create (s_len * 2) in
- let cxt =
- { segment_start = {lnum = 0; offset = 0; byte_bol = 0};
- buf ;
- s_len;
- segments = [];
- pos_lnum = 0;
- byte_bol = 0;
- pos_bol = 0;
+ | {val_send = #bundle_source; _ }
+ -> Location.raise_errorf ~loc "You used an FFI attribute that can't be used with [@@bs.send]"
- } in
- check_and_transform 0 s 0 cxt;
- List.rev cxt.segments
+ | {val_send_pipe = Some typ;
+ (* splice = (false as splice); *)
+ val_send = `Nm_na;
+ val_name = `Nm_na ;
+ call_name = `Nm_na ;
+ module_as_val = None;
+ set_index = false;
+ get_index = false;
+ new_name = `Nm_na;
+ set_name = `Nm_na ;
+ get_name = `Nm_na ;
+ external_module_name = None ;
+ mk_obj = _;
+ return_wrapper = _;
+ scopes;
+ splice ;
+ } ->
+ (** can be one argument *)
+ Js_send {splice ;
+ name = string_of_bundle_source prim_name_or_pval_prim;
+ js_send_scopes = scopes;
+ pipe = true}
+ | {val_send_pipe = Some _ ; _}
+ -> Location.raise_errorf ~loc "conflict attributes found with [@@bs.send.pipe]"
-(** TODO: test empty var $() $ failure,
- Allow identifers x.A.y *)
+ | {new_name = (`Nm_val name | `Nm_external name | `Nm_payload name);
+ external_module_name;
-open Ast_helper
+ val_name = `Nm_na ;
+ call_name = `Nm_na ;
+ module_as_val = None;
+ set_index = false;
+ get_index = false;
+ val_send = `Nm_na ;
+ val_send_pipe = None;
+ set_name = `Nm_na ;
+ get_name = `Nm_na ;
+ splice ;
+ scopes;
+ mk_obj = _ ;
+ return_wrapper = _ ;
-(** Longident.parse "Pervasives.^" *)
-let concat_ident : Longident.t =
- Ldot (Lident "Pervasives", "^")
- (* JS string concatMany *)
- (* Ldot (Ldot (Lident "Js", "String"), "concat") *)
+ }
+ -> Js_new {name; external_module_name; splice; scopes}
+ | {new_name = #bundle_source ; _ }
+ ->
+ Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.new]")
-(* Longident.parse "Js.String.make" *)
-let to_string_ident : Longident.t =
- Ldot (Ldot (Lident "Js", "String"), "make")
+ | {set_name = (`Nm_val name | `Nm_external name | `Nm_payload name);
+ val_name = `Nm_na ;
+ call_name = `Nm_na ;
+ module_as_val = None;
+ set_index = false;
+ get_index = false;
+ val_send = `Nm_na ;
+ val_send_pipe = None;
+ new_name = `Nm_na ;
+ get_name = `Nm_na ;
+ external_module_name = None;
+ splice = false;
+ mk_obj = _ ;
+ return_wrapper = _;
+ scopes ;
+ }
+ ->
+ if arg_type_specs_length = 2 then
+ Js_set { js_set_scopes = scopes ; js_set_name = name}
+ else Location.raise_errorf ~loc "Ill defined attribute [@@bs.set] (two args required)"
-let escaped = Some Literals.escaped_j_delimiter
+ | {set_name = #bundle_source; _}
+ -> Location.raise_errorf ~loc "conflict attributes found with [@@bs.set]"
-let concat_exp
- (a : Parsetree.expression)
- (b : Parsetree.expression) : Parsetree.expression =
- let loc = Bs_loc.merge a.pexp_loc b.pexp_loc in
- Exp.apply ~loc
- (Exp.ident { txt =concat_ident; loc})
- ["",a ;
- "",b]
+ | {get_name = (`Nm_val name | `Nm_external name | `Nm_payload name);
-let border = String.length "{j|"
+ val_name = `Nm_na ;
+ call_name = `Nm_na ;
+ module_as_val = None;
+ set_index = false;
+ get_index = false;
+ val_send = `Nm_na ;
+ val_send_pipe = None;
+ new_name = `Nm_na ;
+ set_name = `Nm_na ;
+ external_module_name = None;
+ splice = false ;
+ mk_obj = _;
+ return_wrapper = _;
+ scopes
+ }
+ ->
+ if arg_type_specs_length = 1 then
+ Js_get { js_get_name = name; js_get_scopes = scopes }
+ else
+ Location.raise_errorf ~loc "Ill defined attribute [@@bs.get] (only one argument)"
+ | {get_name = #bundle_source; _}
+ -> Location.raise_errorf ~loc "Attribute found that conflicts with [@@bs.get]"
-let aux loc (segment : segment) =
- match segment with
- | {start ; finish; kind ; content}
- ->
- let loc = update border start finish loc in
- begin match kind with
- | String ->
- Exp.constant
- ~loc
- (Const_string (content, escaped))
- | Var ->
- Exp.apply ~loc
- (Exp.ident ~loc {loc ; txt = to_string_ident })
- [
- "",
- Exp.ident ~loc {loc ; txt = Lident content}
- ]
- end
+ | {get_name = `Nm_na;
+ val_name = `Nm_na ;
+ call_name = `Nm_na ;
+ module_as_val = None;
+ set_index = false;
+ get_index = false;
+ val_send = `Nm_na ;
+ val_send_pipe = None;
+ new_name = `Nm_na ;
+ set_name = `Nm_na ;
+ external_module_name = None;
+ splice = _ ;
+ scopes = _;
+ mk_obj = _;
+ return_wrapper = _;
+
+ }
+ -> Location.raise_errorf ~loc "Could not infer which FFI category it belongs to, maybe you forgot [%@%@bs.val]? " in
+ begin
+ External_ffi_types.check_ffi ~loc ffi;
+ (* result type can not be labeled *)
+ (* currently we don't process attributes of
+ return type, in the future we may *)
+ let new_result_type = result_type in
+ (* get_arg_type ~nolabel:true false result_type in *)
+ let return_wrapper : External_ffi_types.return_wrapper =
+ check_return_wrapper loc st.return_wrapper new_result_type
+ in
+ (
+ Ext_list.fold_right (fun (label,ty,attrs,loc) acc ->
+ Ast_helper.Typ.arrow ~loc ~attrs label ty acc
+ ) new_arg_types_ty new_result_type
+ ) ,
+ prim_name,
+ (Ffi_bs (arg_type_specs,return_wrapper , ffi)), left_attrs
+ end
-let transform_interp loc s =
- let s_len = String.length s in
- let buf = Buffer.create (s_len * 2 ) in
- try
- let cxt : cxt =
- { segment_start = {lnum = 0; offset = 0; byte_bol = 0};
- buf ;
- s_len;
- segments = [];
- pos_lnum = 0;
- byte_bol = 0;
- pos_bol = 0;
+let handle_attributes_as_string
+ pval_loc
+ pval_prim
+ (typ : Ast_core_type.t) attrs v =
+ let pval_type, prim_name, ffi, processed_attrs =
+ handle_attributes pval_loc pval_prim typ attrs v in
+ pval_type, [prim_name; External_ffi_types.to_string ffi], processed_attrs
- } in
- check_and_transform 0 s 0 cxt;
- let rev_segments = cxt.segments in
- match rev_segments with
- | [] ->
- Exp.constant ~loc
- (Const_string ("", Some Literals.escaped_j_delimiter))
- | [ segment] ->
- aux loc segment
- | a::rest ->
- List.fold_left (fun (acc : Parsetree.expression)
- (x : segment) ->
- concat_exp (aux loc x) acc )
- (aux loc a) rest
- with
- Error (start,pos, error)
- ->
- Location.raise_errorf ~loc:(update border start pos loc )
- "%a" pp_error error
-end
-module Ast_exp : sig
-#1 "ast_exp.mli"
-(* 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 pval_prim_of_labels labels =
+ let encoding =
+ let arg_kinds =
+ Ext_list.fold_right
+ (fun {Asttypes.loc ; txt } arg_kinds
+ ->
+ let arg_label = External_arg_spec.label (Lam_methname.translate ~loc txt) None in
+ {External_arg_spec.arg_type = Nothing ;
+ arg_label } :: arg_kinds
+ )
+ labels [] in
+ External_ffi_types.to_string
+ (Ffi_obj_create arg_kinds) in
+ [""; encoding]
-type t = Parsetree.expression
-end = struct
-#1 "ast_exp.ml"
+end
+module Ast_util : sig
+#1 "ast_util.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -14751,192 +15409,117 @@ end = struct
* 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.expression
-end
-module Ast_external_mk : sig
-#1 "ast_external_mk.mli"
-(* 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 args = (string * Parsetree.expression) list
+type loc = Location.t
+type label_exprs = (Longident.t Asttypes.loc * Parsetree.expression) list
+type 'a cxt = loc -> Bs_ast_mapper.mapper -> 'a
-(**
- [local_module loc ~pval_prim ~pval_type args]
- generate such code
- {[
- let module J = struct
- external unsafe_expr : pval_type = pval_prim
- end in
- J.unssafe_expr args
- ]}
+(** In general three kinds of ast generation.
+ - convert a curried to type to uncurried
+ - convert a curried fun to uncurried fun
+ - convert a uncuried application to normal
*)
-val local_external : Location.t ->
- ?pval_attributes:Parsetree.attributes ->
- pval_prim:string list ->
- pval_type:Parsetree.core_type ->
- ?local_module_name:string ->
- ?local_fun_name:string ->
- (string * Parsetree.expression) list -> Parsetree.expression_desc
+type uncurry_expression_gen =
+ (Parsetree.pattern ->
+ Parsetree.expression ->
+ Parsetree.expression_desc) cxt
+type uncurry_type_gen =
+ (string -> (* label for error checking *)
+ Parsetree.core_type ->
+ Parsetree.core_type ->
+ Parsetree.core_type) cxt
-val local_extern_cont :
- Location.t ->
- ?pval_attributes:Parsetree.attributes ->
- pval_prim:string list ->
- pval_type:Parsetree.core_type ->
- ?local_module_name:string ->
- ?local_fun_name:string ->
- (Parsetree.expression -> Parsetree.expression) -> Parsetree.expression_desc
+(** TODO: the interface is not reusable, it depends on too much context *)
+(** syntax: {[f arg0 arg1 [@bs]]}*)
+val uncurry_fn_apply :
+ (Parsetree.expression ->
+ args ->
+ Parsetree.expression_desc ) cxt
-end = struct
-#1 "ast_external_mk.ml"
-(* 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. *)
+(** syntax : {[f## arg0 arg1 ]}*)
+val method_apply :
+ (Parsetree.expression ->
+ string ->
+ args ->
+ Parsetree.expression_desc) cxt
-let 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_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
- })
+(** syntax {[f#@ arg0 arg1 ]}*)
+val property_apply :
+ (Parsetree.expression ->
+ string ->
+ args ->
+ Parsetree.expression_desc) cxt
-let local_extern_cont loc
- ?(pval_attributes=[])
- ~pval_prim
- ~pval_type
- ?(local_module_name = "J")
- ?(local_fun_name = "unsafe_expr")
- (cb : Parsetree.expression -> 'a)
- : 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_attributes };
- pstr_loc = loc;
- }];
- pmod_loc = loc;
- pmod_attributes = []},
- cb {pexp_desc = Pexp_ident {txt = Ldot (Lident local_module_name, local_fun_name);
- loc};
- pexp_attributes = [] ;
- pexp_loc = loc}
-)
-end
-module Ast_pat : sig
-#1 "ast_pat.mli"
-(* 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. *)
+(**
+ [function] can only take one argument, that is the reason we did not adopt it
+ syntax:
+ {[ fun [@bs] pat pat1-> body ]}
+ [to_uncurry_fn (fun pat -> (fun pat1 -> ... body))]
+
+*)
+val to_uncurry_fn : uncurry_expression_gen
+
+
+(** syntax:
+ {[fun [@bs.this] obj pat pat1 -> body]}
+*)
+val to_method_callback : uncurry_expression_gen
+
-type t = Parsetree.pattern
+(** syntax :
+ {[ int -> int -> int [@bs]]}
+*)
+val to_uncurry_type : uncurry_type_gen
+
-val is_unit_cont : yes:'a -> no:'a -> t -> 'a
+(** syntax
+ {[ method : int -> itn -> int ]}
+*)
+val to_method_type : uncurry_type_gen
-(** [arity_of_fun pat e] tells the arity of
- expression [fun pat -> e]*)
-val arity_of_fun : t -> Parsetree.expression -> int
+(** syntax:
+ {[ 'obj -> int -> int [@bs.this] ]}
+*)
+val to_method_callback_type : uncurry_type_gen
-val is_single_variable_pattern_conservative : t -> bool
+
+
+
+val record_as_js_object :
+ (label_exprs ->
+ Parsetree.expression_desc) cxt
+
+val js_property :
+ loc ->
+ Parsetree.expression -> string -> Parsetree.expression_desc
+
+val handle_debugger :
+ loc -> Ast_payload.t -> Parsetree.expression_desc
+
+val handle_raw :
+ ?check_js_regex: bool -> loc -> Ast_payload.t -> Parsetree.expression
+
+val handle_external :
+ loc -> string -> Parsetree.expression
+
+val handle_raw_structure :
+ loc -> Ast_payload.t -> Parsetree.structure_item
+
+val ocaml_obj_as_js_object :
+ (Parsetree.pattern ->
+ Parsetree.class_field list ->
+ Parsetree.expression_desc) cxt
+
+
+ val convertBsErrorFunction :
+
+ (Ast_helper.attrs -> Parsetree.case list -> Parsetree.expression) cxt
end = struct
-#1 "ast_pat.ml"
+#1 "ast_util.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -14961,815 +15544,670 @@ end = struct
* 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
+type 'a cxt = Ast_helper.loc -> Bs_ast_mapper.mapper -> 'a
+type loc = Location.t
+type args = (string * Parsetree.expression) list
+type label_exprs = (Longident.t Asttypes.loc * Parsetree.expression) list
+type uncurry_expression_gen =
+ (Parsetree.pattern ->
+ Parsetree.expression ->
+ Parsetree.expression_desc) cxt
+type uncurry_type_gen =
+ (string ->
+ Parsetree.core_type ->
+ Parsetree.core_type ->
+ Parsetree.core_type) cxt
-type t = Parsetree.pattern
-
-
-let is_unit_cont ~yes ~no (p : t) =
- match p with
- | {ppat_desc = Ppat_construct({txt = Lident "()"}, None)}
- -> yes
- | _ -> no
-
-
-(** [arity_of_fun pat e] tells the arity of
- expression [fun pat -> e]
-*)
-let arity_of_fun
- (pat : Parsetree.pattern)
- (e : Parsetree.expression) =
- let rec aux (e : Parsetree.expression) =
- match e.pexp_desc with
- | Pexp_fun ("", None, pat, e) ->
- 1 + aux e
- | Pexp_fun _
- -> Location.raise_errorf
- ~loc:e.pexp_loc "Label is not allowed in JS object"
- | _ -> 0 in
- is_unit_cont ~yes:0 ~no:1 pat + aux e
-
-
-let rec is_single_variable_pattern_conservative (p : t ) =
- match p.ppat_desc with
- | Parsetree.Ppat_any
- | Parsetree.Ppat_var _ -> true
- | Parsetree.Ppat_alias (p,_)
- | Parsetree.Ppat_constraint (p, _) ->
- is_single_variable_pattern_conservative p
-
- | _ -> false
-
-end
-module Bs_ast_mapper : sig
-#1 "bs_ast_mapper.mli"
-(***********************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Alain Frisch, LexiFi *)
-(* *)
-(* Copyright 2012 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(** The interface of a -ppx rewriter
-
- A -ppx rewriter is a program that accepts a serialized abstract syntax
- tree and outputs another, possibly modified, abstract syntax tree.
- This module encapsulates the interface between the compiler and
- the -ppx rewriters, handling such details as the serialization format,
- forwarding of command-line flags, and storing state.
-
- {!mapper} allows to implement AST rewriting using open recursion.
- A typical mapper would be based on {!default_mapper}, a deep
- identity mapper, and will fall back on it for handling the syntax it
- does not modify. For example:
-
- {[
-open Asttypes
-open Parsetree
-open Ast_mapper
-
-let test_mapper argv =
- { default_mapper with
- expr = fun mapper expr ->
- match expr with
- | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} ->
- Ast_helper.Exp.constant (Const_int 42)
- | other -> default_mapper.expr mapper other; }
-
-let () =
- register "ppx_test" test_mapper]}
-
- This -ppx rewriter, which replaces [[%test]] in expressions with
- the constant [42], can be compiled using
- [ocamlc -o ppx_test -I +compiler-libs ocamlcommon.cma ppx_test.ml].
-
- *)
-
- open Parsetree
-
- (** {2 A generic Parsetree mapper} *)
-
- type mapper = {
- attribute: mapper -> attribute -> attribute;
- attributes: mapper -> attribute list -> attribute list;
- case: mapper -> case -> case;
- cases: mapper -> case list -> case list;
- class_declaration: mapper -> class_declaration -> class_declaration;
- class_description: mapper -> class_description -> class_description;
- class_expr: mapper -> class_expr -> class_expr;
- class_field: mapper -> class_field -> class_field;
- class_signature: mapper -> class_signature -> class_signature;
- class_structure: mapper -> class_structure -> class_structure;
- class_type: mapper -> class_type -> class_type;
- class_type_declaration: mapper -> class_type_declaration
- -> class_type_declaration;
- class_type_field: mapper -> class_type_field -> class_type_field;
- constructor_declaration: mapper -> constructor_declaration
- -> constructor_declaration;
- expr: mapper -> expression -> expression;
- extension: mapper -> extension -> extension;
- extension_constructor: mapper -> extension_constructor
- -> extension_constructor;
- include_declaration: mapper -> include_declaration -> include_declaration;
- include_description: mapper -> include_description -> include_description;
- label_declaration: mapper -> label_declaration -> label_declaration;
- location: mapper -> Location.t -> Location.t;
- module_binding: mapper -> module_binding -> module_binding;
- module_declaration: mapper -> module_declaration -> module_declaration;
- module_expr: mapper -> module_expr -> module_expr;
- module_type: mapper -> module_type -> module_type;
- module_type_declaration: mapper -> module_type_declaration
- -> module_type_declaration;
- open_description: mapper -> open_description -> open_description;
- pat: mapper -> pattern -> pattern;
- payload: mapper -> payload -> payload;
- signature: mapper -> signature -> signature;
- signature_item: mapper -> signature_item -> signature_item;
- structure: mapper -> structure -> structure;
- structure_item: mapper -> structure_item -> structure_item;
- typ: mapper -> core_type -> core_type;
- type_declaration: mapper -> type_declaration -> type_declaration;
- type_extension: mapper -> type_extension -> type_extension;
- type_kind: mapper -> type_kind -> type_kind;
- value_binding: mapper -> value_binding -> value_binding;
-(* XXXXX *)
- value_bindings_rec: mapper -> value_binding list -> value_binding list;
- value_bindings: mapper -> value_binding list -> value_binding list;
-(* XXXXX *)
- value_description: mapper -> value_description -> value_description;
- with_constraint: mapper -> with_constraint -> with_constraint;
- }
- (** A mapper record implements one "method" per syntactic category,
- using an open recursion style: each method takes as its first
- argument the mapper to be applied to children in the syntax
- tree. *)
-
- val default_mapper: mapper
- (** A default mapper, which implements a "deep identity" mapping. *)
-
-end = struct
-#1 "bs_ast_mapper.ml"
-(***********************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Alain Frisch, LexiFi *)
-(* *)
-(* Copyright 2012 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
+let uncurry_type_id =
+ Ast_literal.Lid.js_fn
-(* A generic Parsetree mapping class *)
-(* Adapted for BUcklescript with more flexibilty*)
+let method_id =
+ Ast_literal.Lid.js_meth
-[@@@ocaml.warning "+9"]
-(* Ensure that record patterns don't miss any field. *)
+let method_call_back_id =
+ Ast_literal.Lid.js_meth_callback
+let arity_lit = "Arity_"
+let mk_args loc n tys =
+ Typ.variant ~loc
+ [ Rtag (arity_lit ^ string_of_int n, [], (n = 0), tys)] Closed None
-open Asttypes
-open Parsetree
-open Ast_helper
-open Location
+let generic_lift txt loc args result =
+ let xs =
+ match args with
+ | [ ] -> [mk_args loc 0 [] ; result ]
+ | [ x ] -> [ mk_args loc 1 [x] ; result ]
+ | _ ->
+ [mk_args loc (List.length args ) [Typ.tuple ~loc args] ; result ]
+ in
+ Typ.constr ~loc {txt ; loc} xs
-type mapper = {
- attribute: mapper -> attribute -> attribute;
- attributes: mapper -> attribute list -> attribute list;
- case: mapper -> case -> case;
- cases: mapper -> case list -> case list;
- class_declaration: mapper -> class_declaration -> class_declaration;
- class_description: mapper -> class_description -> class_description;
- class_expr: mapper -> class_expr -> class_expr;
- class_field: mapper -> class_field -> class_field;
- class_signature: mapper -> class_signature -> class_signature;
- class_structure: mapper -> class_structure -> class_structure;
- class_type: mapper -> class_type -> class_type;
- class_type_declaration: mapper -> class_type_declaration
- -> class_type_declaration;
- class_type_field: mapper -> class_type_field -> class_type_field;
- constructor_declaration: mapper -> constructor_declaration
- -> constructor_declaration;
- expr: mapper -> expression -> expression;
- extension: mapper -> extension -> extension;
- extension_constructor: mapper -> extension_constructor
- -> extension_constructor;
- include_declaration: mapper -> include_declaration -> include_declaration;
- include_description: mapper -> include_description -> include_description;
- label_declaration: mapper -> label_declaration -> label_declaration;
- location: mapper -> Location.t -> Location.t;
- module_binding: mapper -> module_binding -> module_binding;
- module_declaration: mapper -> module_declaration -> module_declaration;
- module_expr: mapper -> module_expr -> module_expr;
- module_type: mapper -> module_type -> module_type;
- module_type_declaration: mapper -> module_type_declaration
- -> module_type_declaration;
- open_description: mapper -> open_description -> open_description;
- pat: mapper -> pattern -> pattern;
- payload: mapper -> payload -> payload;
- signature: mapper -> signature -> signature;
- signature_item: mapper -> signature_item -> signature_item;
- structure: mapper -> structure -> structure;
- structure_item: mapper -> structure_item -> structure_item;
- typ: mapper -> core_type -> core_type;
- type_declaration: mapper -> type_declaration -> type_declaration;
- type_extension: mapper -> type_extension -> type_extension;
- type_kind: mapper -> type_kind -> type_kind;
- value_binding: mapper -> value_binding -> value_binding;
-(* XXXX *)
- value_bindings_rec : mapper -> value_binding list -> value_binding list;
- value_bindings : mapper -> value_binding list -> value_binding list;
-(* XXXXX *)
- value_description: mapper -> value_description -> value_description;
- with_constraint: mapper -> with_constraint -> with_constraint;
-}
+let lift_curry_type loc =
+ generic_lift uncurry_type_id loc
-let map_fst f (x, y) = (f x, y)
-let map_snd f (x, y) = (x, f y)
-let map_tuple f1 f2 (x, y) = (f1 x, f2 y)
-let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
-let map_opt f = function None -> None | Some x -> Some (f x)
+let lift_method_type loc =
+ generic_lift method_id loc
-let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt}
+let lift_js_method_callback loc
+ =
+ generic_lift method_call_back_id loc
+(** Note that currently there is no way to consume [Js.meth_callback]
+ so it is fine to encode it with a freedom,
+ but we need make it better for error message.
+ - all are encoded as
+ {[
+ type fn = (`Args_n of _ , 'result ) Js.fn
+ type method = (`Args_n of _, 'result) Js.method
+ type method_callback = (`Args_n of _, 'result) Js.method_callback
+ ]}
+ For [method_callback], the arity is never zero, so both [method]
+ and [fn] requires (unit -> 'a) to encode arity zero
+*)
-module T = struct
- (* Type expressions for the core language *)
- let row_field sub = function
- | Rtag (l, attrs, b, tl) ->
- Rtag (l, sub.attributes sub attrs, b, List.map (sub.typ sub) tl)
- | Rinherit t -> Rinherit (sub.typ sub t)
- let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} =
- let open Typ in
- let loc = sub.location sub loc in
- let attrs = sub.attributes sub attrs in
- match desc with
- | Ptyp_any -> any ~loc ~attrs ()
- | Ptyp_var s -> var ~loc ~attrs s
- | Ptyp_arrow (lab, t1, t2) ->
- arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2)
- | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl)
- | Ptyp_constr (lid, tl) ->
- constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
- | Ptyp_object (l, o) ->
- let f (s, a, t) = (s, sub.attributes sub a, sub.typ sub t) in
- object_ ~loc ~attrs (List.map f l) o
- | Ptyp_class (lid, tl) ->
- class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
- | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s
- | Ptyp_variant (rl, b, ll) ->
- variant ~loc ~attrs (List.map (row_field sub) rl) b ll
- | Ptyp_poly (sl, t) -> poly ~loc ~attrs sl (sub.typ sub t)
- | Ptyp_package (lid, l) ->
- package ~loc ~attrs (map_loc sub lid)
- (List.map (map_tuple (map_loc sub) (sub.typ sub)) l)
- | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x)
+let arrow = Typ.arrow
- let map_type_declaration sub
- {ptype_name; ptype_params; ptype_cstrs;
- ptype_kind;
- ptype_private;
- ptype_manifest;
- ptype_attributes;
- ptype_loc} =
- Type.mk (map_loc sub ptype_name)
- ~params:(List.map (map_fst (sub.typ sub)) ptype_params)
- ~priv:ptype_private
- ~cstrs:(List.map
- (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub))
- ptype_cstrs)
- ~kind:(sub.type_kind sub ptype_kind)
- ?manifest:(map_opt (sub.typ sub) ptype_manifest)
- ~loc:(sub.location sub ptype_loc)
- ~attrs:(sub.attributes sub ptype_attributes)
- let map_type_kind sub = function
- | Ptype_abstract -> Ptype_abstract
- | Ptype_variant l ->
- Ptype_variant (List.map (sub.constructor_declaration sub) l)
- | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l)
- | Ptype_open -> Ptype_open
+let js_property loc obj name =
+ Parsetree.Pexp_send
+ ((Exp.apply ~loc
+ (Exp.ident ~loc
+ {loc;
+ txt = Ldot (Ast_literal.Lid.js_unsafe, Literals.unsafe_downgrade)})
+ ["",obj]), name)
+
+(* TODO:
+ have a final checking for property arities
+ [#=],
+*)
+
+
+let generic_apply kind loc
+ (self : Bs_ast_mapper.mapper)
+ (obj : Parsetree.expression)
+ (args : args ) cb =
+ let obj = self.expr self obj in
+ let args =
+ Ext_list.map (fun (label,e) ->
+ if label <> "" then
+ Bs_syntaxerr.err loc Label_in_uncurried_bs_attribute;
+ self.expr self e
+ ) args in
+ let len = List.length args in
+ let arity, fn, args =
+ match args with
+ | [ {pexp_desc =
+ Pexp_construct ({txt = Lident "()"}, None)}]
+ ->
+ 0, cb loc obj, []
+ | _ ->
+ len, cb loc obj, args in
+ if arity < 10 then
+ let txt =
+ match kind with
+ | `Fn | `PropertyFn ->
+ Longident.Ldot (Ast_literal.Lid.js_unsafe,
+ Literals.fn_run ^ string_of_int arity)
+ | `Method ->
+ Longident.Ldot(Ast_literal.Lid.js_unsafe,
+ Literals.method_run ^ string_of_int arity
+ ) in
+ Parsetree.Pexp_apply (Exp.ident {txt ; loc}, ("",fn) :: Ext_list.map (fun x -> "",x) args)
+ else
+ let fn_type, args_type, result_type = Ast_comb.tuple_type_pair ~loc `Run arity in
+ let string_arity = string_of_int arity in
+ let pval_prim, pval_type =
+ match kind with
+ | `Fn | `PropertyFn ->
+ ["#fn_run"; string_arity],
+ arrow ~loc "" (lift_curry_type loc args_type result_type ) fn_type
+ | `Method ->
+ ["#method_run" ; string_arity],
+ arrow ~loc "" (lift_method_type loc args_type result_type) fn_type
+ in
+ Ast_external_mk.local_external loc ~pval_prim ~pval_type
+ (("", fn) :: Ext_list.map (fun x -> "",x) args )
+
+
+let uncurry_fn_apply loc self fn args =
+ generic_apply `Fn loc self fn args (fun _ obj -> obj )
+
+let property_apply loc self obj name (args : args)
+ = generic_apply `PropertyFn loc self obj args
+ (fun loc obj -> Exp.mk ~loc (js_property loc obj name))
+
+let method_apply loc self obj name args =
+ generic_apply `Method loc self obj args
+ (fun loc obj -> Exp.mk ~loc (js_property loc obj name))
+
+let generic_to_uncurry_type kind loc (mapper : Bs_ast_mapper.mapper) label
+ (first_arg : Parsetree.core_type)
+ (typ : Parsetree.core_type) =
+ if label <> "" then
+ Bs_syntaxerr.err loc Label_in_uncurried_bs_attribute;
+
+ let rec aux acc (typ : Parsetree.core_type) =
+ (* in general,
+ we should collect [typ] in [int -> typ] before transformation,
+ however: when attributes [bs] and [bs.this] found in typ,
+ we should stop
+ *)
+ match Ast_attributes.process_attributes_rev typ.ptyp_attributes with
+ | `Nothing, _ ->
+ begin match typ.ptyp_desc with
+ | Ptyp_arrow (label, arg, body)
+ ->
+ if label <> "" then
+ Bs_syntaxerr.err typ.ptyp_loc Label_in_uncurried_bs_attribute;
+ aux (mapper.typ mapper arg :: acc) body
+ | _ -> mapper.typ mapper typ, acc
+ end
+ | _, _ -> mapper.typ mapper typ, acc
+ in
+ let first_arg = mapper.typ mapper first_arg in
+ let result, rev_extra_args = aux [first_arg] typ in
+ let args = List.rev rev_extra_args in
+ let filter_args args =
+ match args with
+ | [{Parsetree.ptyp_desc =
+ (Ptyp_constr ({txt = Lident "unit"}, [])
+ )}]
+ -> []
+ | _ -> args in
+ match kind with
+ | `Fn ->
+ let args = filter_args args in
+ lift_curry_type loc args result
+ | `Method ->
+ let args = filter_args args in
+ lift_method_type loc args result
+
+ | `Method_callback
+ -> lift_js_method_callback loc args result
- let map_type_extension sub
- {ptyext_path; ptyext_params;
- ptyext_constructors;
- ptyext_private;
- ptyext_attributes} =
- Te.mk
- (map_loc sub ptyext_path)
- (List.map (sub.extension_constructor sub) ptyext_constructors)
- ~params:(List.map (map_fst (sub.typ sub)) ptyext_params)
- ~priv:ptyext_private
- ~attrs:(sub.attributes sub ptyext_attributes)
- let map_extension_constructor_kind sub = function
- Pext_decl(ctl, cto) ->
- Pext_decl(List.map (sub.typ sub) ctl, map_opt (sub.typ sub) cto)
- | Pext_rebind li ->
- Pext_rebind (map_loc sub li)
+let to_uncurry_type =
+ generic_to_uncurry_type `Fn
+let to_method_type =
+ generic_to_uncurry_type `Method
+let to_method_callback_type =
+ generic_to_uncurry_type `Method_callback
- let map_extension_constructor sub
- {pext_name;
- pext_kind;
- pext_loc;
- pext_attributes} =
- Te.constructor
- (map_loc sub pext_name)
- (map_extension_constructor_kind sub pext_kind)
- ~loc:(sub.location sub pext_loc)
- ~attrs:(sub.attributes sub pext_attributes)
+let generic_to_uncurry_exp kind loc (self : Bs_ast_mapper.mapper) pat body
+ =
+ let rec aux acc (body : Parsetree.expression) =
+ match Ast_attributes.process_attributes_rev body.pexp_attributes with
+ | `Nothing, _ ->
+ begin match body.pexp_desc with
+ | Pexp_fun (label,_, arg, body)
+ ->
+ if label <> "" then
+ Bs_syntaxerr.err loc Label_in_uncurried_bs_attribute;
+ aux (self.pat self arg :: acc) body
+ | _ -> self.expr self body, acc
+ end
+ | _, _ -> self.expr self body, acc
+ in
+ let first_arg = self.pat self pat in
+ let () =
+ match kind with
+ | `Method_callback ->
+ if not @@ Ast_pat.is_single_variable_pattern_conservative first_arg then
+ Bs_syntaxerr.err first_arg.ppat_loc Bs_this_simple_pattern
+ | _ -> ()
+ in
-end
+ let result, rev_extra_args = aux [first_arg] body in
+ let body =
+ List.fold_left (fun e p -> Ast_comb.fun_no_label ~loc p e )
+ result rev_extra_args in
+ let len = List.length rev_extra_args in
+ let arity =
+ match kind with
+ | `Fn ->
+ begin match rev_extra_args with
+ | [ p]
+ ->
+ Ast_pat.is_unit_cont ~yes:0 ~no:len p
-module CT = struct
- (* Type expressions for the class language *)
+ | _ -> len
+ end
+ | `Method_callback -> len in
+ if arity < 10 then
+ let txt =
+ match kind with
+ | `Fn ->
+ Longident.Ldot ( Ast_literal.Lid.js_unsafe, Literals.fn_mk ^ string_of_int arity)
+ | `Method_callback ->
+ Longident.Ldot (Ast_literal.Lid.js_unsafe, Literals.fn_method ^ string_of_int arity) in
+ Parsetree.Pexp_apply (Exp.ident {txt;loc} , ["",body])
- let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} =
- let open Cty in
- let loc = sub.location sub loc in
- let attrs = sub.attributes sub attrs in
- match desc with
- | Pcty_constr (lid, tys) ->
- constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys)
- | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x)
- | Pcty_arrow (lab, t, ct) ->
- arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct)
- | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x)
+ else
+ let pval_prim =
+ [ (match kind with
+ | `Fn -> "#fn_mk"
+ | `Method_callback -> "#fn_method");
+ string_of_int arity] in
+ let fn_type , args_type, result_type = Ast_comb.tuple_type_pair ~loc `Make arity in
+ let pval_type = arrow ~loc "" fn_type (
+ match kind with
+ | `Fn ->
+ lift_curry_type loc args_type result_type
+ | `Method_callback ->
+ lift_js_method_callback loc args_type result_type
+ ) in
+ Ast_external_mk.local_extern_cont loc ~pval_prim ~pval_type
+ (fun prim -> Exp.apply ~loc prim ["", body])
- let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs}
- =
- let open Ctf in
- let loc = sub.location sub loc in
- let attrs = sub.attributes sub attrs in
- match desc with
- | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct)
- | Pctf_val (s, m, v, t) -> val_ ~loc ~attrs s m v (sub.typ sub t)
- | Pctf_method (s, p, v, t) -> method_ ~loc ~attrs s p v (sub.typ sub t)
- | Pctf_constraint (t1, t2) ->
- constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2)
- | Pctf_attribute x -> attribute ~loc (sub.attribute sub x)
- | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x)
+let to_uncurry_fn =
+ generic_to_uncurry_exp `Fn
+let to_method_callback =
+ generic_to_uncurry_exp `Method_callback
- let map_signature sub {pcsig_self; pcsig_fields} =
- Csig.mk
- (sub.typ sub pcsig_self)
- (List.map (sub.class_type_field sub) pcsig_fields)
-end
-module MT = struct
- (* Type expressions for the module language *)
+let handle_debugger loc payload =
+ if Ast_payload.as_empty_structure payload then
+ Parsetree.Pexp_apply
+ (Exp.ident {txt = Ldot(Ast_literal.Lid.js_unsafe, Literals.debugger ); loc},
+ ["", Ast_literal.val_unit ~loc ()])
+ else Location.raise_errorf ~loc "bs.raw can only be applied to a string"
- let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} =
- let open Mty in
- let loc = sub.location sub loc in
- let attrs = sub.attributes sub attrs in
- match desc with
- | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s)
- | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s)
- | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg)
- | Pmty_functor (s, mt1, mt2) ->
- functor_ ~loc ~attrs (map_loc sub s)
- (Misc.may_map (sub.module_type sub) mt1)
- (sub.module_type sub mt2)
- | Pmty_with (mt, l) ->
- with_ ~loc ~attrs (sub.module_type sub mt)
- (List.map (sub.with_constraint sub) l)
- | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me)
- | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x)
- let map_with_constraint sub = function
- | Pwith_type (lid, d) ->
- Pwith_type (map_loc sub lid, sub.type_declaration sub d)
- | Pwith_module (lid, lid2) ->
- Pwith_module (map_loc sub lid, map_loc sub lid2)
- | Pwith_typesubst d -> Pwith_typesubst (sub.type_declaration sub d)
- | Pwith_modsubst (s, lid) ->
- Pwith_modsubst (map_loc sub s, map_loc sub lid)
+let handle_raw ?(check_js_regex = false) loc payload =
+ begin match Ast_payload.as_string_exp ~check_js_regex payload with
+ | Not_String_Lteral ->
+ Location.raise_errorf ~loc
+ "bs.raw can only be applied to a string"
+ | Ast_payload.JS_Regex_Check_Failed ->
+ Location.raise_errorf ~loc "this is an invalid js regex"
+ | Correct exp ->
+ let pexp_desc =
+ Parsetree.Pexp_apply (
+ Exp.ident {loc;
+ txt =
+ Ldot (Ast_literal.Lid.js_unsafe,
+ Literals.raw_expr)},
+ ["",exp]
+ )
+ in
+ { exp with pexp_desc }
+ end
+
+let handle_external loc x =
+ let raw_exp : Ast_exp.t =
+ Ast_helper.Exp.apply
+ (Exp.ident ~loc
+ {loc; txt = Ldot (Ast_literal.Lid.js_unsafe,
+ Literals.raw_expr)})
+ ~loc
+ [Ext_string.empty,
+ Exp.constant ~loc (Const_string (x,Some Ext_string.empty))] in
+ let empty =
+ Exp.ident ~loc
+ {txt = Ldot (Ldot(Lident"Js", "Undefined"), "empty");loc}
+ in
+ let undefined_typeof =
+ Exp.ident {loc ; txt = Ldot(Lident "Js","undefinedToOption")} in
+ let typeof =
+ Exp.ident {loc ; txt = Ldot(Lident "Js","typeof")} in
+
+ Exp.apply ~loc undefined_typeof [
+ Ext_string.empty,
+ Exp.ifthenelse ~loc
+ (Exp.apply ~loc
+ (Exp.ident ~loc {loc ; txt = Ldot (Lident "Pervasives", "=")} )
+ [
+ Ext_string.empty,
+ (Exp.apply ~loc typeof [Ext_string.empty,raw_exp]);
+ Ext_string.empty,
+ Exp.constant ~loc (Const_string ("undefined",None))
+ ])
+ (empty)
+ (Some raw_exp)
+ ]
- let map_signature_item sub {psig_desc = desc; psig_loc = loc} =
- let open Sig in
- let loc = sub.location sub loc in
- match desc with
- | Psig_value vd -> value ~loc (sub.value_description sub vd)
- | Psig_type l -> type_ ~loc (List.map (sub.type_declaration sub) l)
- | Psig_typext te -> type_extension ~loc (sub.type_extension sub te)
- | Psig_exception ed -> exception_ ~loc (sub.extension_constructor sub ed)
- | Psig_module x -> module_ ~loc (sub.module_declaration sub x)
- | Psig_recmodule l ->
- rec_module ~loc (List.map (sub.module_declaration sub) l)
- | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x)
- | Psig_open x -> open_ ~loc (sub.open_description sub x)
- | Psig_include x -> include_ ~loc (sub.include_description sub x)
- | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l)
- | Psig_class_type l ->
- class_type ~loc (List.map (sub.class_type_declaration sub) l)
- | Psig_extension (x, attrs) ->
- extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs)
- | Psig_attribute x -> attribute ~loc (sub.attribute sub x)
-end
+let handle_raw_structure loc payload =
+ begin match Ast_payload.as_string_exp payload with
+ | Correct exp
+ ->
+ let pexp_desc =
+ Parsetree.Pexp_apply(
+ Exp.ident {txt = Ldot (Ast_literal.Lid.js_unsafe, Literals.raw_stmt); loc},
+ ["",exp]) in
+ Ast_helper.Str.eval
+ { exp with pexp_desc }
-module M = struct
- (* Value expressions for the module language *)
+ | Not_String_Lteral
+ ->
+ Location.raise_errorf ~loc "bs.raw can only be applied to a string"
+ | JS_Regex_Check_Failed
+ ->
+ Location.raise_errorf ~loc "this is an invalid js regex"
+ end
- let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} =
- let open Mod in
- let loc = sub.location sub loc in
- let attrs = sub.attributes sub attrs in
- match desc with
- | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x)
- | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str)
- | Pmod_functor (arg, arg_ty, body) ->
- functor_ ~loc ~attrs (map_loc sub arg)
- (Misc.may_map (sub.module_type sub) arg_ty)
- (sub.module_expr sub body)
- | Pmod_apply (m1, m2) ->
- apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2)
- | Pmod_constraint (m, mty) ->
- constraint_ ~loc ~attrs (sub.module_expr sub m)
- (sub.module_type sub mty)
- | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e)
- | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x)
- let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} =
- let open Str in
- let loc = sub.location sub loc in
- match desc with
- | Pstr_eval (x, attrs) ->
- eval ~loc ~attrs:(sub.attributes sub attrs) (sub.expr sub x)
- | Pstr_value (r, vbs) ->
-(* XXX *)
-(* value ~loc r (List.map (sub.value_binding sub) vbs) *)
- value ~loc r
- ((if r = Recursive then sub.value_bindings_rec else sub.value_bindings)
- sub vbs)
-(* XXX *)
- | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd)
- | Pstr_type l -> type_ ~loc (List.map (sub.type_declaration sub) l)
- | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te)
- | Pstr_exception ed -> exception_ ~loc (sub.extension_constructor sub ed)
- | Pstr_module x -> module_ ~loc (sub.module_binding sub x)
- | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l)
- | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x)
- | Pstr_open x -> open_ ~loc (sub.open_description sub x)
- | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l)
- | Pstr_class_type l ->
- class_type ~loc (List.map (sub.class_type_declaration sub) l)
- | Pstr_include x -> include_ ~loc (sub.include_declaration sub x)
- | Pstr_extension (x, attrs) ->
- extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs)
- | Pstr_attribute x -> attribute ~loc (sub.attribute sub x)
-end
+let ocaml_obj_as_js_object
+ loc (mapper : Bs_ast_mapper.mapper)
+ (self_pat : Parsetree.pattern)
+ (clfs : Parsetree.class_field list) =
+ let self_type_lit = "self_type" in
-module E = struct
- (* Value expressions for the core language *)
+ (** Attention: we should avoid type variable conflict for each method
+ Since the method name is unique, there would be no conflict
+ OCaml does not allow duplicate instance variable and duplicate methods,
+ but it does allow duplicates between instance variable and method name,
+ we should enforce such rules
+ {[
+ object
+ val x = 3
+ method x = 3
+ end [@bs]
+ ]} should not compile with a meaningful error message
+ *)
- let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} =
- let open Exp in
- let loc = sub.location sub loc in
- let attrs = sub.attributes sub attrs in
- match desc with
- | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x)
- | Pexp_constant x -> constant ~loc ~attrs x
- | Pexp_let (r, vbs, e) ->
-(* XXXX *)
- (* let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs)
- (sub.expr sub e) *)
- let_ ~loc ~attrs r
- (
- (if r = Recursive then sub.value_bindings_rec else sub.value_bindings)
- sub vbs
- )
- (sub.expr sub e)
-(* XXXX *)
- | Pexp_fun (lab, def, p, e) ->
- fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p)
- (sub.expr sub e)
- | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel)
- | Pexp_apply (e, l) ->
- apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l)
- | Pexp_match (e, pel) ->
- match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
- | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
- | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el)
- | Pexp_construct (lid, arg) ->
- construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg)
- | Pexp_variant (lab, eo) ->
- variant ~loc ~attrs lab (map_opt (sub.expr sub) eo)
- | Pexp_record (l, eo) ->
- record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l)
- (map_opt (sub.expr sub) eo)
- | Pexp_field (e, lid) ->
- field ~loc ~attrs (sub.expr sub e) (map_loc sub lid)
- | Pexp_setfield (e1, lid, e2) ->
- setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid)
- (sub.expr sub e2)
- | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el)
- | Pexp_ifthenelse (e1, e2, e3) ->
- ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
- (map_opt (sub.expr sub) e3)
- | Pexp_sequence (e1, e2) ->
- sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
- | Pexp_while (e1, e2) ->
- while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
- | Pexp_for (p, e1, e2, d, e3) ->
- for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d
- (sub.expr sub e3)
- | Pexp_coerce (e, t1, t2) ->
- coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1)
- (sub.typ sub t2)
- | Pexp_constraint (e, t) ->
- constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t)
- | Pexp_send (e, s) -> send ~loc ~attrs (sub.expr sub e) s
- | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid)
- | Pexp_setinstvar (s, e) ->
- setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e)
- | Pexp_override sel ->
- override ~loc ~attrs
- (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel)
- | Pexp_letmodule (s, me, e) ->
- letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me)
- (sub.expr sub e)
- | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e)
- | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e)
- | Pexp_poly (e, t) ->
- poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t)
- | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls)
- | Pexp_newtype (s, e) -> newtype ~loc ~attrs s (sub.expr sub e)
- | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me)
- | Pexp_open (ovf, lid, e) ->
- open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e)
- | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x)
-end
+ let generate_val_method_pair
+ loc (mapper : Bs_ast_mapper.mapper)
+ val_name is_mutable =
-module P = struct
- (* Patterns *)
+ let result = Typ.var ~loc val_name in
+ result ,
+ ((val_name , [], result ) ::
+ (if is_mutable then
+ [val_name ^ Literals.setter_suffix,[],
+ to_method_type loc mapper "" result (Ast_literal.type_unit ~loc ()) ]
+ else
+ []) )
+ in
+ (* Note mapper is only for API compatible
+ * TODO: we should check label name to avoid conflict
+ *)
+ let self_type loc = Typ.var ~loc self_type_lit in
- let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} =
- let open Pat in
- let loc = sub.location sub loc in
- let attrs = sub.attributes sub attrs in
- match desc with
- | Ppat_any -> any ~loc ~attrs ()
- | Ppat_var s -> var ~loc ~attrs (map_loc sub s)
- | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s)
- | Ppat_constant c -> constant ~loc ~attrs c
- | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2
- | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl)
- | Ppat_construct (l, p) ->
- construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p)
- | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p)
- | Ppat_record (lpl, cf) ->
- record ~loc ~attrs
- (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf
- | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl)
- | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2)
- | Ppat_constraint (p, t) ->
- constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t)
- | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s)
- | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p)
- | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s)
- | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p)
- | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x)
-end
+ let generate_arg_type loc (mapper : Bs_ast_mapper.mapper)
+ method_name arity : Ast_core_type.t =
+ let result = Typ.var ~loc method_name in
+ if arity = 0 then
+ to_method_type loc mapper "" (Ast_literal.type_unit ~loc ()) result
-module CE = struct
- (* Value expressions for the class language *)
+ else
+ let tyvars =
+ Ext_list.init arity (fun i -> Typ.var ~loc (method_name ^ string_of_int i))
+ in
+ begin match tyvars with
+ | x :: rest ->
+ let method_rest =
+ Ext_list.fold_right (fun v acc -> Typ.arrow ~loc "" v acc)
+ rest result in
+ to_method_type loc mapper "" x method_rest
+ | _ -> assert false
+ end in
- let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} =
- let open Cl in
- let loc = sub.location sub loc in
- let attrs = sub.attributes sub attrs in
- match desc with
- | Pcl_constr (lid, tys) ->
- constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys)
- | Pcl_structure s ->
- structure ~loc ~attrs (sub.class_structure sub s)
- | Pcl_fun (lab, e, p, ce) ->
- fun_ ~loc ~attrs lab
- (map_opt (sub.expr sub) e)
- (sub.pat sub p)
- (sub.class_expr sub ce)
- | Pcl_apply (ce, l) ->
- apply ~loc ~attrs (sub.class_expr sub ce)
- (List.map (map_snd (sub.expr sub)) l)
- | Pcl_let (r, vbs, ce) ->
-(* XXXX *)
- (* let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs)
- (sub.class_expr sub ce) *)
- let_ ~loc ~attrs r
- ((if r = Recursive then sub.value_bindings_rec else sub.value_bindings)
- sub vbs)
- (sub.class_expr sub ce)
-(* XXXX *)
- | Pcl_constraint (ce, ct) ->
- constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct)
- | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x)
+ let generate_method_type
+ loc
+ (mapper : Bs_ast_mapper.mapper)
+ ?alias_type method_name arity =
+ let result = Typ.var ~loc method_name in
- let map_kind sub = function
- | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e)
- | Cfk_virtual t -> Cfk_virtual (sub.typ sub t)
+ let self_type =
+ let v = self_type loc in
+ match alias_type with
+ | None -> v
+ | Some ty -> Typ.alias ~loc ty self_type_lit
+ in
+ if arity = 0 then
+ to_method_callback_type loc mapper "" self_type result
+ else
+ let tyvars =
+ Ext_list.init arity (fun i -> Typ.var ~loc (method_name ^ string_of_int i))
+ in
+ begin match tyvars with
+ | x :: rest ->
+ let method_rest =
+ Ext_list.fold_right (fun v acc -> Typ.arrow ~loc "" v acc)
+ rest result in
+ (to_method_callback_type loc mapper "" self_type
+ (Typ.arrow ~loc "" x method_rest))
+ | _ -> assert false
+ end in
- let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} =
- let open Cf in
- let loc = sub.location sub loc in
- let attrs = sub.attributes sub attrs in
- match desc with
- | Pcf_inherit (o, ce, s) -> inherit_ ~loc ~attrs o (sub.class_expr sub ce) s
- | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k)
- | Pcf_method (s, p, k) ->
- method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k)
- | Pcf_constraint (t1, t2) ->
- constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2)
- | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e)
- | Pcf_attribute x -> attribute ~loc (sub.attribute sub x)
- | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x)
- let map_structure sub {pcstr_self; pcstr_fields} =
- {
- pcstr_self = sub.pat sub pcstr_self;
- pcstr_fields = List.map (sub.class_field sub) pcstr_fields;
- }
+ (** we need calculate the real object type
+ and exposed object type, in some cases there are equivalent
- let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr;
- pci_loc; pci_attributes} =
- Ci.mk
- ~virt:pci_virt
- ~params:(List.map (map_fst (sub.typ sub)) pl)
- (map_loc sub pci_name)
- (f pci_expr)
- ~loc:(sub.location sub pci_loc)
- ~attrs:(sub.attributes sub pci_attributes)
-end
+ for public object type its [@bs.meth] it does not depend on itself
+ while for label argument it is [@bs.this] which depends internal object
+ *)
+ let internal_label_attr_types, public_label_attr_types =
+ Ext_list.fold_right
+ (fun ({pcf_loc = loc} as x : Parsetree.class_field)
+ (label_attr_types, public_label_attr_types) ->
+ match x.pcf_desc with
+ | Pcf_method (
+ label,
+ public_flag,
+ Cfk_concrete
+ (Fresh, e))
+ ->
+ begin match e.pexp_desc with
+ | Pexp_poly
+ (({pexp_desc = Pexp_fun ("", None, pat, e)} ),
+ None) ->
+ let arity = Ast_pat.arity_of_fun pat e in
+ let method_type =
+ generate_arg_type x.pcf_loc mapper label.txt arity in
+ ((label.Asttypes.txt, [], method_type) :: label_attr_types),
+ (if public_flag = Public then
+ (label.Asttypes.txt, [], method_type) :: public_label_attr_types
+ else
+ public_label_attr_types)
-(* Now, a generic AST mapper, to be extended to cover all kinds and
- cases of the OCaml grammar. The default behavior of the mapper is
- the identity. *)
+ | Pexp_poly( _, Some _)
+ ->
+ Location.raise_errorf ~loc "polymorphic type annotation not supported yet"
+ | Pexp_poly (_, None) ->
+ Location.raise_errorf ~loc
+ "Unsupported syntax, expect syntax like `method x () = x ` "
+ | _ ->
+ Location.raise_errorf ~loc "Unsupported syntax in js object"
+ end
+ | Pcf_val (label, mutable_flag, Cfk_concrete(Fresh, val_exp)) ->
+ let label_type, label_attr =
+ generate_val_method_pair x.pcf_loc mapper label.txt
+ (mutable_flag = Mutable )
+ in
+ (Ext_list.append label_attr label_attr_types, public_label_attr_types)
+ | Pcf_val (label, mutable_flag, Cfk_concrete(Override, val_exp)) ->
+ Location.raise_errorf ~loc "override flag not support currently"
+ | Pcf_val (label, mutable_flag, Cfk_virtual _) ->
+ Location.raise_errorf ~loc "virtual flag not support currently"
-let default_mapper =
- {
- structure = (fun this l -> List.map (this.structure_item this) l);
- structure_item = M.map_structure_item;
- module_expr = M.map;
- signature = (fun this l -> List.map (this.signature_item this) l);
- signature_item = MT.map_signature_item;
- module_type = MT.map;
- with_constraint = MT.map_with_constraint;
- class_declaration =
- (fun this -> CE.class_infos this (this.class_expr this));
- class_expr = CE.map;
- class_field = CE.map_field;
- class_structure = CE.map_structure;
- class_type = CT.map;
- class_type_field = CT.map_field;
- class_signature = CT.map_signature;
- class_type_declaration =
- (fun this -> CE.class_infos this (this.class_type this));
- class_description =
- (fun this -> CE.class_infos this (this.class_type this));
- type_declaration = T.map_type_declaration;
- type_kind = T.map_type_kind;
- typ = T.map;
- type_extension = T.map_type_extension;
- extension_constructor = T.map_extension_constructor;
- value_description =
- (fun this {pval_name; pval_type; pval_prim; pval_loc;
- pval_attributes} ->
- Val.mk
- (map_loc this pval_name)
- (this.typ this pval_type)
- ~attrs:(this.attributes this pval_attributes)
- ~loc:(this.location this pval_loc)
- ~prim:pval_prim
- );
+ | Pcf_method (_, _, Cfk_concrete(Override, _) ) ->
+ Location.raise_errorf ~loc "override flag not supported"
- pat = P.map;
- expr = E.map;
+ | Pcf_method (_, _, Cfk_virtual _ )
+ ->
+ Location.raise_errorf ~loc "virtural method not supported"
- module_declaration =
- (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} ->
- Md.mk
- (map_loc this pmd_name)
- (this.module_type this pmd_type)
- ~attrs:(this.attributes this pmd_attributes)
- ~loc:(this.location this pmd_loc)
- );
+ | Pcf_inherit _
+ | Pcf_initializer _
+ | Pcf_attribute _
+ | Pcf_extension _
+ | Pcf_constraint _ ->
+ Location.raise_errorf ~loc "Only method support currently"
+ ) clfs ([], []) in
+ let internal_obj_type = Ast_core_type.make_obj ~loc internal_label_attr_types in
+ let public_obj_type = Ast_core_type.make_obj ~loc public_label_attr_types in
+ let (labels, label_types, exprs, _) =
+ Ext_list.fold_right
+ (fun (x : Parsetree.class_field)
+ (labels,
+ label_types,
+ exprs, aliased ) ->
+ match x.pcf_desc with
+ | Pcf_method (
+ label,
+ _public_flag,
+ Cfk_concrete
+ (Fresh, e))
+ ->
+ begin match e.pexp_desc with
+ | Pexp_poly
+ (({pexp_desc = Pexp_fun ("", None, pat, e)} as f),
+ None) ->
+ let arity = Ast_pat.arity_of_fun pat e in
+ let alias_type =
+ if aliased then None
+ else Some internal_obj_type in
+ let label_type =
+ generate_method_type ?alias_type
+ x.pcf_loc mapper label.txt arity in
+ (label::labels,
+ label_type::label_types,
+ {f with
+ pexp_desc =
+ let f = Ast_pat.is_unit_cont pat ~yes:e ~no:f in
+ to_method_callback loc mapper self_pat f
+ } :: exprs,
+ true
+ )
+ | Pexp_poly( _, Some _)
+ ->
+ Location.raise_errorf ~loc
+ "polymorphic type annotation not supported yet"
- module_type_declaration =
- (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} ->
- Mtd.mk
- (map_loc this pmtd_name)
- ?typ:(map_opt (this.module_type this) pmtd_type)
- ~attrs:(this.attributes this pmtd_attributes)
- ~loc:(this.location this pmtd_loc)
- );
+ | Pexp_poly (_, None) ->
+ Location.raise_errorf
+ ~loc "Unsupported syntax, expect syntax like `method x () = x ` "
+ | _ ->
+ Location.raise_errorf ~loc "Unsupported syntax in js object"
+ end
+ | Pcf_val (label, mutable_flag, Cfk_concrete(Fresh, val_exp)) ->
+ let label_type, label_attr =
+ generate_val_method_pair x.pcf_loc mapper label.txt
+ (mutable_flag = Mutable )
+ in
+ (label::labels,
+ label_type :: label_types,
+ (mapper.expr mapper val_exp :: exprs),
+ aliased
+ )
- module_binding =
- (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} ->
- Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr)
- ~attrs:(this.attributes this pmb_attributes)
- ~loc:(this.location this pmb_loc)
- );
+ | Pcf_val (label, mutable_flag, Cfk_concrete(Override, val_exp)) ->
+ Location.raise_errorf ~loc "override flag not support currently"
+ | Pcf_val (label, mutable_flag, Cfk_virtual _) ->
+ Location.raise_errorf ~loc "virtual flag not support currently"
+ | Pcf_method (_, _, Cfk_concrete(Override, _) ) ->
+ Location.raise_errorf ~loc "override flag not supported"
- open_description =
- (fun this {popen_lid; popen_override; popen_attributes; popen_loc} ->
- Opn.mk (map_loc this popen_lid)
- ~override:popen_override
- ~loc:(this.location this popen_loc)
- ~attrs:(this.attributes this popen_attributes)
- );
+ | Pcf_method (_, _, Cfk_virtual _ )
+ ->
+ Location.raise_errorf ~loc "virtural method not supported"
- include_description =
- (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
- Incl.mk (this.module_type this pincl_mod)
- ~loc:(this.location this pincl_loc)
- ~attrs:(this.attributes this pincl_attributes)
- );
+ | Pcf_inherit _
+ | Pcf_initializer _
+ | Pcf_attribute _
+ | Pcf_extension _
+ | Pcf_constraint _ ->
+ Location.raise_errorf ~loc "Only method support currently"
+ ) clfs ([], [], [], false) in
+ let pval_type =
+ Ext_list.fold_right2
+ (fun label label_type acc ->
+ Typ.arrow
+ ~loc:label.Asttypes.loc
+ label.Asttypes.txt
+ label_type acc
+ ) labels label_types public_obj_type in
+ Ast_external_mk.local_extern_cont
+ loc
+ ~pval_prim:(External_process.pval_prim_of_labels labels)
+ (fun e ->
+ Exp.apply ~loc e
+ (Ext_list.map2 (fun l expr -> l.Asttypes.txt, expr) labels exprs) )
+ ~pval_type
- include_declaration =
- (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
- Incl.mk (this.module_expr this pincl_mod)
- ~loc:(this.location this pincl_loc)
- ~attrs:(this.attributes this pincl_attributes)
- );
- value_bindings = (fun this vbs ->
- match vbs with
- | [vb] -> [ this.value_binding this vb ]
- | _ -> List.map (this.value_binding this) vbs
- );
- value_bindings_rec = (fun this vbs ->
- match vbs with
- | [vb] -> [ this.value_binding this vb ]
- | _ -> List.map (this.value_binding this) vbs
- );
- value_binding =
- (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} ->
- Vb.mk
- (this.pat this pvb_pat)
- (this.expr this pvb_expr)
- ~loc:(this.location this pvb_loc)
- ~attrs:(this.attributes this pvb_attributes)
- );
+let record_as_js_object
+ loc
+ (self : Bs_ast_mapper.mapper)
+ (label_exprs : label_exprs)
+ : Parsetree.expression_desc =
+ let labels,args, arity =
+ Ext_list.fold_right (fun ({Location.txt ; loc}, e) (labels,args,i) ->
+ match txt with
+ | Longident.Lident x ->
+ ({Asttypes.loc = loc ; txt = x} :: labels, (x, self.expr self e) :: args, i + 1)
+ | Ldot _ | Lapply _ ->
+ Location.raise_errorf ~loc "invalid js label ") label_exprs ([],[],0) in
+ Ast_external_mk.local_external loc
+ ~pval_prim:(External_process.pval_prim_of_labels labels)
+ ~pval_type:(Ast_core_type.from_labels ~loc arity labels)
+ args
- constructor_declaration =
- (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} ->
- Type.constructor
- (map_loc this pcd_name)
- ~args:(List.map (this.typ this) pcd_args)
- ?res:(map_opt (this.typ this) pcd_res)
- ~loc:(this.location this pcd_loc)
- ~attrs:(this.attributes this pcd_attributes)
- );
- label_declaration =
- (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} ->
- Type.field
- (map_loc this pld_name)
- (this.typ this pld_type)
- ~mut:pld_mutable
- ~loc:(this.location this pld_loc)
- ~attrs:(this.attributes this pld_attributes)
- );
- cases = (fun this l -> List.map (this.case this) l);
- case =
- (fun this {pc_lhs; pc_guard; pc_rhs} ->
- {
- pc_lhs = this.pat this pc_lhs;
- pc_guard = map_opt (this.expr this) pc_guard;
- pc_rhs = this.expr this pc_rhs;
- }
- );
+let isCamlExceptionOrOpenVariant = Longident.parse "Caml_exceptions.isCamlExceptionOrOpenVariant"
+let obj_magic = Longident.parse "Obj.magic"
+let rec checkCases (cases : Parsetree.case list) =
+ List.iter check_case cases
+and check_case case =
+ check_pat case.pc_lhs
+and check_pat (pat : Parsetree.pattern) =
+ match pat.ppat_desc with
+ | Ppat_construct _ -> ()
+ | Ppat_or (l,r) ->
+ check_pat l; check_pat r
+ | _ -> Location.raise_errorf ~loc:pat.ppat_loc "Unsupported pattern in `bs.open`"
+let convertBsErrorFunction loc (self : Bs_ast_mapper.mapper) attrs (cases : Parsetree.case list ) =
+ let txt = "match" in
+ let txt_expr = Exp.ident ~loc {txt = Lident txt; loc} in
+ let none = Exp.constraint_ ~loc
+ (Exp.construct ~loc {txt = Lident "None" ; loc} None)
+ (Ast_core_type.lift_option_type (Typ.any ~loc ())) in
+ let () = checkCases cases in
+ let cases = self.cases self cases in
+ Exp.fun_ ~attrs ~loc "" None ( Pat.var ~loc {txt; loc })
+ (Exp.ifthenelse
+ ~loc
+ (Exp.apply ~loc (Exp.ident ~loc {txt = isCamlExceptionOrOpenVariant ; loc}) ["", txt_expr ])
+ (Exp.match_ ~loc
+ (Exp.constraint_ ~loc
+ (Exp.apply ~loc (Exp.ident ~loc {txt = obj_magic; loc}) ["", txt_expr])
+ (Ast_literal.type_exn ~loc ())
+ )
+ (Ext_list.map_append (fun (x :Parsetree.case ) ->
+ let pc_rhs = x.pc_rhs in
+ let loc = pc_rhs.pexp_loc in
+ {
+ x with pc_rhs =
+ Exp.constraint_ ~loc
+ (Exp.construct ~loc {txt = Lident "Some";loc} (Some pc_rhs))
+ (Ast_core_type.lift_option_type (Typ.any ~loc ()) )
+ }
- location = (fun this l -> l);
+ ) cases
+ [
+ Exp.case (Pat.any ~loc ()) none
+ ])
+ )
+ (Some none))
+
+
- extension = (fun this (s, e) -> (map_loc this s, this.payload this e));
- attribute = (fun this (s, e) -> (map_loc this s, this.payload this e));
- attributes = (fun this l -> List.map (this.attribute this) l);
- payload =
- (fun this -> function
- | PStr x -> PStr (this.structure this x)
- | PTyp x -> PTyp (this.typ this x)
- | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g)
- );
- }
end
-module Bs_version : sig
-#1 "bs_version.mli"
+module Ext_ref : sig
+#1 "ext_ref.mli"
(* 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
@@ -15787,21 +16225,31 @@ module Bs_version : sig
* 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 version : string
+(** [non_exn_protect ref value f] assusme [f()]
+ would not raise
+*)
-val header : string
+val non_exn_protect : 'a ref -> 'a -> (unit -> 'b) -> 'b
+val protect : 'a ref -> 'a -> (unit -> 'b) -> 'b
-val package_name : string
-end = struct
-#1 "bs_version.ml"
+val protect2 : 'a ref -> 'b ref -> 'a -> 'b -> (unit -> 'c) -> 'c
+
+(** [non_exn_protect2 refa refb va vb f ]
+ assume [f ()] would not raise
+*)
+val non_exn_protect2 : 'a ref -> 'b ref -> 'a -> 'b -> (unit -> 'c) -> 'c
+
+val protect_list : ('a ref * 'a) list -> (unit -> 'b) -> 'b
+end = struct
+#1 "ext_ref.ml"
(* 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
@@ -15819,19 +16267,107 @@ end = struct
* 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 version = "2.2.3"
-let header =
- "// Generated by BUCKLESCRIPT VERSION 2.2.3, PLEASE EDIT WITH CARE"
-let package_name = "bs-platform"
-
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
+
+let non_exn_protect r v body =
+ let old = !r in
+ r := v;
+ let res = body() in
+ r := old;
+ res
+
+let protect r v body =
+ let old = !r in
+ try
+ r := v;
+ let res = body() in
+ r := old;
+ res
+ with x ->
+ r := old;
+ raise x
+
+let non_exn_protect2 r1 r2 v1 v2 body =
+ let old1 = !r1 in
+ let old2 = !r2 in
+ r1 := v1;
+ r2 := v2;
+ let res = body() in
+ r1 := old1;
+ r2 := old2;
+ res
+
+let protect2 r1 r2 v1 v2 body =
+ let old1 = !r1 in
+ let old2 = !r2 in
+ try
+ r1 := v1;
+ r2 := v2;
+ let res = body() in
+ r1 := old1;
+ r2 := old2;
+ res
+ with x ->
+ r1 := old1;
+ r2 := old2;
+ raise x
+
+let protect_list rvs body =
+ let olds = Ext_list.map (fun (x,y) -> !x) rvs in
+ let () = List.iter (fun (x,y) -> x:=y) rvs in
+ try
+ let res = body () in
+ List.iter2 (fun (x,_) old -> x := old) rvs olds;
+ res
+ with e ->
+ List.iter2 (fun (x,_) old -> x := old) rvs olds;
+ raise e
+
end
-module External_ffi_types : sig
-#1 "external_ffi_types.mli"
-(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+module Ast_core_type_class_type : sig
+#1 "ast_core_type_class_type.mli"
+(* Copyright (C) 2018 Authors of BuckleScript
+ *
+ * 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 handle_class_type_fields :
+ Bs_ast_mapper.mapper ->
+ Parsetree.class_type_field list ->
+ Parsetree.class_type_field list
+
+val handle_core_type :
+ Bs_ast_mapper.mapper ->
+ Parsetree.core_type ->
+ bool ref ->
+ Parsetree.core_type
+end = struct
+#1 "ast_core_type_class_type.ml"
+(* Copyright (C) 2018 Authors of BuckleScript
*
* 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
@@ -15854,121 +16390,203 @@ module External_ffi_types : sig
* 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. *)
+open Ast_helper
+let process_getter_setter ~no ~get ~set
+ loc name
+ (attrs : Ast_attributes.t)
+ (ty : Parsetree.core_type) acc =
+ match Ast_attributes.process_method_attributes_rev attrs with
+ | {get = None; set = None}, _ -> no ty :: acc
+ | st , pctf_attributes
+ ->
+ let get_acc =
+ match st.set with
+ | Some `No_get -> acc
+ | None
+ | Some `Get ->
+ let lift txt =
+ Typ.constr ~loc {txt ; loc} [ty] in
+ let (null,undefined) =
+ match st with
+ | {get = Some (null, undefined) } -> (null, undefined)
+ | {get = None} -> (false, false ) in
+ let ty =
+ match (null,undefined) with
+ | false, false -> ty
+ | true, false -> lift Ast_literal.Lid.js_null
+ | false, true -> lift Ast_literal.Lid.js_undefined
+ | true , true -> lift Ast_literal.Lid.js_null_undefined in
+ get ty name pctf_attributes
+ :: acc
+ in
+ if st.set = None then get_acc
+ else
+ set ty (name ^ Literals.setter_suffix) pctf_attributes
+ :: get_acc
-type module_bind_name =
- | Phint_name of string
- (* explicit hint name *)
- | Phint_nothing
-
-type external_module_name =
- { bundle : string ;
- module_bind_name : module_bind_name
- }
-
-type pipe = bool
-type js_call = {
- name : string;
- external_module_name : external_module_name option;
- splice : bool ;
- scopes : string list
-}
-
-type js_send = {
- name : string ;
- splice : bool ;
- pipe : pipe ;
- js_send_scopes : string list;
-} (* we know it is a js send, but what will happen if you pass an ocaml objct *)
-
-type js_global_val = {
- name : string ;
- external_module_name : external_module_name option;
- scopes : string list
-}
-
-type js_new_val = {
- name : string ;
- external_module_name : external_module_name option;
- splice : bool ;
- scopes : string list;
-}
-
-type js_module_as_fn =
- { external_module_name : external_module_name;
- splice : bool
- }
-
-type arg_type = External_arg_spec.attr
-
-type arg_label = External_arg_spec.label
-
-
-type obj_create = External_arg_spec.t list
-
-type js_get =
- { js_get_name : string ;
- js_get_scopes : string list;
- }
-
-type js_set =
- { js_set_name : string ;
- js_set_scopes : string list
- }
-
-
-type js_get_index = {
- js_get_index_scopes : string list
-}
-
-type js_set_index = {
- js_set_index_scopes : string list
-}
-
-
-
-type attr =
- | Js_global of js_global_val
- | Js_module_as_var of external_module_name
- | Js_module_as_fn of js_module_as_fn
- | Js_module_as_class of external_module_name
- | Js_call of js_call
- | Js_send of js_send
- | Js_new of js_new_val
- | Js_set of js_set
- | Js_get of js_get
- | Js_get_index of js_get_index
- | Js_set_index of js_set_index
-
-type return_wrapper =
- | Return_unset
- | Return_identity
- | Return_undefined_to_opt
- | Return_null_to_opt
- | Return_null_undefined_to_opt
- | Return_to_ocaml_bool
- | Return_replaced_with_unit
-
-type t =
- | Ffi_bs of
- External_arg_spec.t list *
- return_wrapper * attr
- | Ffi_obj_create of obj_create
- | Ffi_normal
- (* When it's normal, it is handled as normal c functional ffi call *)
-
-
-val name_of_ffi : attr -> string
-val check_ffi : ?loc:Location.t -> attr -> unit
+let handle_class_type_field self
+ ({pctf_loc = loc } as ctf : Parsetree.class_type_field)
+ acc =
+ match ctf.pctf_desc with
+ | Pctf_method
+ (name, private_flag, virtual_flag, ty)
+ ->
+ let no (ty : Parsetree.core_type) =
+ let ty =
+ match ty.ptyp_desc with
+ | Ptyp_arrow (label, args, body)
+ ->
+ Ast_util.to_method_type
+ ty.ptyp_loc self label args body
-val to_string : t -> string
+ | Ptyp_poly (strs, {ptyp_desc = Ptyp_arrow (label, args, body);
+ ptyp_loc})
+ ->
+ {ty with ptyp_desc =
+ Ptyp_poly(strs,
+ Ast_util.to_method_type
+ ptyp_loc self label args body )}
+ | _ ->
+ self.typ self ty
+ in
+ {ctf with
+ pctf_desc =
+ Pctf_method (name , private_flag, virtual_flag, ty)}
+ in
+ let get ty name pctf_attributes =
+ {ctf with
+ pctf_desc =
+ Pctf_method (name ,
+ private_flag,
+ virtual_flag,
+ self.typ self ty
+ );
+ pctf_attributes} in
+ let set ty name pctf_attributes =
+ {ctf with
+ pctf_desc =
+ Pctf_method (name,
+ private_flag,
+ virtual_flag,
+ Ast_util.to_method_type
+ loc self "" ty
+ (Ast_literal.type_unit ~loc ())
+ );
+ pctf_attributes} in
+ process_getter_setter ~no ~get ~set loc name ctf.pctf_attributes ty acc
-(** Note *)
-val from_string : string -> t
+ | Pctf_inherit _
+ | Pctf_val _
+ | Pctf_constraint _
+ | Pctf_attribute _
+ | Pctf_extension _ ->
+ Bs_ast_mapper.default_mapper.class_type_field self ctf :: acc
+
+(*
+ Attributes are very hard to attribute
+ (since ptyp_attributes could happen in so many places),
+ and write ppx extensions correctly,
+ we can only use it locally
+*)
-end = struct
-#1 "external_ffi_types.ml"
+let handle_core_type
+ ~(super : Bs_ast_mapper.mapper)
+ ~(self : Bs_ast_mapper.mapper)
+ (ty : Parsetree.core_type)
+ record_as_js_object
+ =
+ match ty with
+ | {ptyp_desc = Ptyp_extension({txt = ("bs.obj"|"obj")}, PTyp ty)}
+ ->
+ Ext_ref.non_exn_protect record_as_js_object true
+ (fun _ -> self.typ self ty )
+ | {ptyp_attributes ;
+ ptyp_desc = Ptyp_arrow (label, args, body);
+ (* let it go without regard label names,
+ it will report error later when the label is not empty
+ *)
+ ptyp_loc = loc
+ } ->
+ begin match Ast_attributes.process_attributes_rev ptyp_attributes with
+ | `Uncurry , ptyp_attributes ->
+ Ast_util.to_uncurry_type loc self label args body
+ | `Meth_callback, ptyp_attributes ->
+ Ast_util.to_method_callback_type loc self label args body
+ | `Method, ptyp_attributes ->
+ Ast_util.to_method_type loc self label args body
+ | `Nothing , _ ->
+ Bs_ast_mapper.default_mapper.typ self ty
+ end
+ | {
+ ptyp_desc = Ptyp_object ( methods, closed_flag) ;
+ ptyp_loc = loc
+ } ->
+ let (+>) attr (typ : Parsetree.core_type) =
+ {typ with ptyp_attributes = attr :: typ.ptyp_attributes} in
+ let new_methods =
+ Ext_list.fold_right (fun (label, ptyp_attrs, core_type) acc ->
+ let get ty name attrs =
+ let attrs, core_type =
+ match Ast_attributes.process_attributes_rev attrs with
+ | `Nothing, attrs -> attrs, ty (* #1678 *)
+ | `Uncurry, attrs ->
+ attrs, Ast_attributes.bs +> ty
+ | `Method, _
+ -> Location.raise_errorf ~loc "bs.get/set conflicts with bs.meth"
+ | `Meth_callback, attrs ->
+ attrs, Ast_attributes.bs_this +> ty
+ in
+ name , attrs, self.typ self core_type in
+ let set ty name attrs =
+ let attrs, core_type =
+ match Ast_attributes.process_attributes_rev attrs with
+ | `Nothing, attrs -> attrs, ty
+ | `Uncurry, attrs ->
+ attrs, Ast_attributes.bs +> ty
+ | `Method, _
+ -> Location.raise_errorf ~loc "bs.get/set conflicts with bs.meth"
+ | `Meth_callback, attrs ->
+ attrs, Ast_attributes.bs_this +> ty
+ in
+ name, attrs, Ast_util.to_method_type loc self "" core_type
+ (Ast_literal.type_unit ~loc ()) in
+ let no ty =
+ let attrs, core_type =
+ match Ast_attributes.process_attributes_rev ptyp_attrs with
+ | `Nothing, attrs -> attrs, ty
+ | `Uncurry, attrs ->
+ attrs, Ast_attributes.bs +> ty
+ | `Method, attrs ->
+ attrs, Ast_attributes.bs_method +> ty
+ | `Meth_callback, attrs ->
+ attrs, Ast_attributes.bs_this +> ty in
+ label, attrs, self.typ self core_type in
+ process_getter_setter ~no ~get ~set
+ loc label ptyp_attrs core_type acc
+ ) methods [] in
+ let inner_type =
+ { ty
+ with ptyp_desc = Ptyp_object(new_methods, closed_flag);
+ } in
+ if !record_as_js_object then
+ Ast_comb.to_js_type loc inner_type
+ else inner_type
+ | _ -> super.typ self ty
+
+let handle_class_type_fields self fields =
+ Ext_list.fold_right
+ (handle_class_type_field self)
+ fields []
+
+let handle_core_type self typ record_as_js_object =
+ handle_core_type
+ ~super:Bs_ast_mapper.default_mapper
+ ~self typ record_as_js_object
+end
+module Ast_signature : sig
+#1 "ast_signature.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -15991,272 +16609,150 @@ end = struct
*
* 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 module_bind_name =
- | Phint_name of string
- (* explicit hint name *)
-
- | Phint_nothing
-
-
-type external_module_name =
- { bundle : string ;
- module_bind_name : module_bind_name
- }
-
-type pipe = bool
-type js_call = {
- name : string;
- external_module_name : external_module_name option;
- splice : bool ;
- scopes : string list ;
-}
-
-type js_send = {
- name : string ;
- splice : bool ;
- pipe : pipe ;
- js_send_scopes : string list;
-} (* we know it is a js send, but what will happen if you pass an ocaml objct *)
-
-type js_global_val = {
- name : string ;
- external_module_name : external_module_name option;
- scopes : string list ;
-}
-
-type js_new_val = {
- name : string ;
- external_module_name : external_module_name option;
- splice : bool ;
- scopes : string list;
-}
-
-type js_module_as_fn =
- { external_module_name : external_module_name;
- splice : bool ;
-
- }
-type js_get =
- { js_get_name : string ;
- js_get_scopes : string list;
- }
-
-type js_set =
- { js_set_name : string ;
- js_set_scopes : string list
- }
-
-type js_get_index = {
- js_get_index_scopes : string list
-}
-
-type js_set_index = {
- js_set_index_scopes : string list
-}
-(** TODO: information between [arg_type] and [arg_label] are duplicated,
- design a more compact representation so that it is also easy to seralize by hand
-*)
-type arg_type = External_arg_spec.attr
-
-type arg_label = External_arg_spec.label
-
-
-(**TODO: maybe we can merge [arg_label] and [arg_type] *)
-type obj_create = External_arg_spec.t list
-
-type attr =
- | Js_global of js_global_val
- | Js_module_as_var of external_module_name
- | Js_module_as_fn of js_module_as_fn
- | Js_module_as_class of external_module_name
- | Js_call of js_call
- | Js_send of js_send
- | Js_new of js_new_val
- | Js_set of js_set
- | Js_get of js_get
- | Js_get_index of js_get_index
- | Js_set_index of js_set_index
-
-let name_of_ffi ffi =
- match ffi with
- | Js_get_index _scope -> "[@@bs.get_index ..]"
- | Js_set_index _scope -> "[@@bs.set_index ..]"
- | Js_get { js_get_name = s} -> Printf.sprintf "[@@bs.get %S]" s
- | Js_set { js_set_name = s} -> Printf.sprintf "[@@bs.set %S]" s
- | Js_call v -> Printf.sprintf "[@@bs.val %S]" v.name
- | Js_send v -> Printf.sprintf "[@@bs.send %S]" v.name
- | Js_module_as_fn v -> Printf.sprintf "[@@bs.val %S]" v.external_module_name.bundle
- | Js_new v -> Printf.sprintf "[@@bs.new %S]" v.name
- | Js_module_as_class v
- -> Printf.sprintf "[@@bs.module] %S " v.bundle
- | Js_module_as_var v
- ->
- Printf.sprintf "[@@bs.module] %S " v.bundle
- | Js_global v
- ->
- Printf.sprintf "[@@bs.val] %S " v.name
-
-type return_wrapper =
- | Return_unset
- | Return_identity
- | Return_undefined_to_opt
- | Return_null_to_opt
- | Return_null_undefined_to_opt
- | Return_to_ocaml_bool
- | Return_replaced_with_unit
-type t =
- | Ffi_bs of External_arg_spec.t list *
- return_wrapper * attr
- (** [Ffi_bs(args,return,attr) ]
- [return] means return value is unit or not,
- [true] means is [unit]
- *)
- | Ffi_obj_create of obj_create
- | Ffi_normal
- (* When it's normal, it is handled as normal c functional ffi call *)
-
-
-
-let valid_js_char =
- let a = Array.init 256 (fun i ->
- let c = Char.chr i in
- (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || (c >= '0' && c <= '9') || c = '_' || c = '$'
- ) in
- (fun c -> Array.unsafe_get a (Char.code c))
-
-let valid_first_js_char =
- let a = Array.init 256 (fun i ->
- let c = Char.chr i in
- (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || c = '_' || c = '$'
- ) in
- (fun c -> Array.unsafe_get a (Char.code c))
-
-(** Approximation could be improved *)
-let valid_ident (s : string) =
- let len = String.length s in
- len > 0 && valid_js_char s.[0] && valid_first_js_char s.[0] &&
- (let module E = struct exception E end in
- try
- for i = 1 to len - 1 do
- if not (valid_js_char (String.unsafe_get s i)) then
- raise E.E
- done ;
- true
- with E.E -> false )
-
-let valid_global_name ?loc txt =
- if not (valid_ident txt) then
- let v = Ext_string.split_by ~keep_empty:true (fun x -> x = '.') txt in
- List.iter
- (fun s ->
- if not (valid_ident s) then
- Location.raise_errorf ?loc "Not a valid global name %s" txt
- ) v
-
-let valid_method_name ?loc txt =
- if not (valid_ident txt) then
- Location.raise_errorf ?loc "Not a valid method name %s" txt
-
-
-
-let check_external_module_name ?loc x =
- match x with
- | {bundle = ""; _ }
- | { module_bind_name = Phint_name "" } ->
- Location.raise_errorf ?loc "empty name encountered"
- | _ -> ()
-let check_external_module_name_opt ?loc x =
- match x with
- | None -> ()
- | Some v -> check_external_module_name ?loc v
-
-
-let check_ffi ?loc ffi =
- match ffi with
- | Js_global {name} -> valid_global_name ?loc name
- | Js_send {name }
- | Js_set {js_set_name = name}
- | Js_get { js_get_name = name}
- -> valid_method_name ?loc name
- | Js_get_index _ (* TODO: check scopes *)
- | Js_set_index _
- -> ()
-
- | Js_module_as_var external_module_name
- | Js_module_as_fn {external_module_name; _}
- | Js_module_as_class external_module_name
- -> check_external_module_name external_module_name
- | Js_new {external_module_name ; name}
- | Js_call {external_module_name ; name ; _}
- ->
- check_external_module_name_opt ?loc external_module_name ;
- valid_global_name ?loc name
-
-let bs_prefix = "BS:"
-let bs_prefix_length = String.length bs_prefix
-
-
-(** TODO: Make sure each version is not prefix of each other
- Solution:
- 1. fixed length
- 2. non-prefix approach
-*)
-let bs_external = bs_prefix ^ Bs_version.version
-
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-let bs_external_length = String.length bs_external
+type item = Parsetree.signature_item
+type t = item list
-let to_string t =
- bs_external ^ Marshal.to_string t []
+val fuseAll : ?loc:Ast_helper.loc -> t -> item
+end = struct
+#1 "ast_signature.ml"
+(* 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 item = Parsetree.signature_item
+type t = item list
-(* TODO: better error message when version mismatch *)
-let from_string s : t =
- let s_len = String.length s in
- if s_len >= bs_prefix_length &&
- String.unsafe_get s 0 = 'B' &&
- String.unsafe_get s 1 = 'S' &&
- String.unsafe_get s 2 = ':' then
- if Ext_string.starts_with s bs_external then
- Marshal.from_string s bs_external_length
- else
- Ext_pervasives.failwithf
- ~loc:__LOC__
- "Compiler version mismatch. The project might have been built with one version of BuckleScript, and then with another. Please wipe the artifacts and do a clean build."
- else Ffi_normal
+open Ast_helper
+let fuseAll ?(loc=Location.none) (t : t) : item =
+ Sig.include_ ~loc (Incl.mk ~loc (Mty.signature ~loc t))
+
end
-module Bs_hash_stubs
-= struct
-#1 "bs_hash_stubs.ml"
+module Ast_structure : sig
+#1 "ast_structure.mli"
+(* 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. *)
-external hash_string : string -> int = "caml_bs_hash_string" "noalloc";;
+type item = Parsetree.structure_item
-external hash_string_int : string -> int -> int = "caml_bs_hash_string_and_int" "noalloc";;
+type t = item list
-external hash_string_small_int : string -> int -> int = "caml_bs_hash_string_and_small_int" "noalloc";;
-external hash_stamp_and_name : int -> string -> int = "caml_bs_hash_stamp_and_name" "noalloc";;
+val fuseAll: ?loc:Ast_helper.loc -> t -> item
-external hash_small_int : int -> int = "caml_bs_hash_small_int" "noalloc";;
+(* val fuse_with_constraint:
+ ?loc:Ast_helper.loc ->
+ Parsetree.type_declaration list ->
+ t ->
+ Ast_signature.t ->
+ item *)
-external hash_int : int -> int = "caml_bs_hash_int" "noalloc";;
+val constraint_ : ?loc:Ast_helper.loc -> t -> Ast_signature.t -> item
-external string_length_based_compare : string -> string -> int = "caml_string_length_based_compare" "noalloc";;
+end = struct
+#1 "ast_structure.ml"
+(* 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 item = Parsetree.structure_item
-external
- int_unsafe_blit :
- int array -> int -> int array -> int -> int -> unit = "caml_int_array_blit" "noalloc";;
+type t = item list
+
+open Ast_helper
+
+
+let fuseAll ?(loc=Location.none) (t : t) : item =
+ Str.include_ ~loc
+ (Incl.mk ~loc (Mod.structure ~loc t ))
+(* let fuse_with_constraint
+ ?(loc=Location.none)
+ (item : Parsetree.type_declaration list ) (t : t) (coercion) =
+ Str.include_ ~loc
+ (Incl.mk ~loc
+ (Mod.constraint_
+ (Mod.structure ~loc
+ ({pstr_loc = loc; pstr_desc = Pstr_type item} :: t) )
+ (
+ Mty.signature ~loc
+ ({psig_loc = loc; psig_desc = Psig_type item} :: coercion)
+ )
+ )
+ ) *)
+let constraint_ ?(loc=Location.none) (stru : t) (sign : Ast_signature.t) =
+ Str.include_ ~loc
+ (Incl.mk ~loc
+ (Mod.constraint_ ~loc (Mod.structure ~loc stru) (Mty.signature ~loc sign)))
end
-module String_hash_set : sig
-#1 "string_hash_set.mli"
+module Ast_derive : sig
+#1 "ast_derive.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -16281,12 +16777,51 @@ module String_hash_set : sig
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
+type tdcls = Parsetree.type_declaration list
+
+type gen = {
+ structure_gen : tdcls -> bool -> Ast_structure.t ;
+ signature_gen : tdcls -> bool -> Ast_signature.t ;
+ expression_gen : (Parsetree.core_type -> Parsetree.expression) option ;
+}
+
+(**
+ [register name cb]
+ example: [register "accessors" cb]
+*)
+val register :
+ string ->
+ (Parsetree.expression option -> gen) ->
+ unit
+
+(* val gen_structure:
+ tdcls ->
+ Ast_payload.action list ->
+ bool ->
+ Ast_structure.t *)
+
+val gen_signature:
+ tdcls ->
+ Ast_payload.action list ->
+ bool ->
+ Ast_signature.t
+
+
+val gen_expression :
+ string Asttypes.loc ->
+ Parsetree.core_type ->
+ Parsetree.expression
+
-include Hash_set_gen.S with type key = string
+val gen_structure_signature :
+ Location.t ->
+ Parsetree.type_declaration list ->
+ Ast_payload.action ->
+ bool ->
+ Parsetree.structure_item
end = struct
-#1 "string_hash_set.ml"
-# 1 "ext/hash_set.cppo.ml"
+#1 "ast_derive.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -16310,80 +16845,83 @@ end = struct
* 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. *)
-# 31
-type key = string
-let key_index (h : _ Hash_set_gen.t ) (key : key) =
- (Bs_hash_stubs.hash_string key) land (Array.length h.data - 1)
-let eq_key = Ext_string.equal
-type t = key Hash_set_gen.t
+type tdcls = Parsetree.type_declaration list
-# 62
-let create = Hash_set_gen.create
-let clear = Hash_set_gen.clear
-let reset = Hash_set_gen.reset
-let copy = Hash_set_gen.copy
-let iter = Hash_set_gen.iter
-let fold = Hash_set_gen.fold
-let length = Hash_set_gen.length
-let stats = Hash_set_gen.stats
-let elements = Hash_set_gen.elements
+type gen = {
+ structure_gen : tdcls -> bool -> Ast_structure.t ;
+ signature_gen : tdcls -> bool -> Ast_signature.t ;
+ expression_gen : (Parsetree.core_type -> Parsetree.expression) option ;
+}
+(* the first argument is [config] payload
+ {[
+ { x = {uu} }
+ ]}
+*)
+type derive_table =
+ (Parsetree.expression option -> gen) String_map.t
+let derive_table : derive_table ref = ref String_map.empty
-let remove (h : _ Hash_set_gen.t) key =
- let i = key_index h key in
- let h_data = h.data in
- let old_h_size = h.size in
- let new_bucket = Hash_set_gen.remove_bucket eq_key key h (Array.unsafe_get h_data i) in
- if old_h_size <> h.size then
- Array.unsafe_set h_data i new_bucket
+let register key value =
+ derive_table := String_map.add key value !derive_table
-let add (h : _ Hash_set_gen.t) key =
- let i = key_index h key in
- let h_data = h.data in
- let old_bucket = (Array.unsafe_get h_data i) in
- if not (Hash_set_gen.small_bucket_mem eq_key key old_bucket) then
- begin
- Array.unsafe_set h_data i (key :: old_bucket);
- h.size <- h.size + 1 ;
- if h.size > Array.length h_data lsl 1 then Hash_set_gen.resize key_index h
- end
+(* let gen_structure
+ (tdcls : tdcls)
+ (actions : Ast_payload.action list )
+ (explict_nonrec : bool )
+ : Ast_structure.t =
+ Ext_list.flat_map
+ (fun action ->
+ (Ast_payload.table_dispatch !derive_table action).structure_gen
+ tdcls explict_nonrec) actions *)
-let of_array arr =
- let len = Array.length arr in
- let tbl = create len in
- for i = 0 to len - 1 do
- add tbl (Array.unsafe_get arr i);
- done ;
- tbl
-
-
-let check_add (h : _ Hash_set_gen.t) key =
- let i = key_index h key in
- let h_data = h.data in
- let old_bucket = (Array.unsafe_get h_data i) in
- if not (Hash_set_gen.small_bucket_mem eq_key key old_bucket) then
- begin
- Array.unsafe_set h_data i (key :: old_bucket);
- h.size <- h.size + 1 ;
- if h.size > Array.length h_data lsl 1 then Hash_set_gen.resize key_index h;
- true
- end
- else false
+let gen_signature
+ tdcls
+ (actions : Ast_payload.action list )
+ (explict_nonrec : bool )
+ : Ast_signature.t =
+ Ext_list.flat_map
+ (fun action ->
+ (Ast_payload.table_dispatch !derive_table action).signature_gen
+ tdcls explict_nonrec) actions
+(** used for cases like [%sexp] *)
+let gen_expression ({Asttypes.txt ; loc}) typ =
+ let txt = Ext_string.tail_from txt (String.length Literals.bs_deriving_dot) in
+ match (Ast_payload.table_dispatch !derive_table
+ ({txt ; loc}, None)).expression_gen with
+ | None ->
+ Bs_syntaxerr.err loc (Unregistered txt)
-let mem (h : _ Hash_set_gen.t) key =
- Hash_set_gen.small_bucket_mem eq_key key (Array.unsafe_get h.data (key_index h key))
+ | Some f -> f typ
-
+open Ast_helper
+let gen_structure_signature
+ loc
+ (tdcls : tdcls)
+ (action : Ast_payload.action)
+ (explicit_nonrec : bool) =
+ let derive_table = !derive_table in
+ let u =
+ Ast_payload.table_dispatch derive_table action in
+ let a = u.structure_gen tdcls explicit_nonrec in
+ let b = u.signature_gen tdcls explicit_nonrec in
+ Str.include_ ~loc
+ (Incl.mk ~loc
+ (Mod.constraint_ ~loc
+ (Mod.structure ~loc a)
+ (Mty.signature ~loc b )
+ )
+ )
end
-module Lam_methname : sig
-#1 "lam_methname.mli"
-(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+module Ast_derive_util : sig
+#1 "ast_derive_util.mli"
+(* Copyright (C) 2017 Authors of BuckleScript
*
* 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
@@ -16407,14 +16945,40 @@ module Lam_methname : sig
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
+(** Given a type declaration, extaract the type expression, mostly
+ used in code gen later
+ *)
+ val core_type_of_type_declaration :
+ Parsetree.type_declaration -> Parsetree.core_type
+val new_type_of_type_declaration :
+ Parsetree.type_declaration ->
+ string ->
+ Parsetree.core_type * Parsetree.type_declaration
-val translate : ?loc:Location.t -> string -> string
+val lift_string_list_to_array : string list -> Parsetree.expression
+val lift_int : int -> Parsetree.expression
+val lift_int_list_to_array : int list -> Parsetree.expression
+val mk_fun :
+ loc:Location.t ->
+ Parsetree.core_type ->
+ string -> Parsetree.expression -> Parsetree.expression
+val destruct_label_declarations :
+ loc:Location.t ->
+ string ->
+ Parsetree.label_declaration list ->
+ (Parsetree.core_type * Parsetree.expression) list * string list
+
+val notApplicable:
+ Location.t ->
+ string ->
+ unit
+val invalid_config : Parsetree.expression -> 'a
end = struct
-#1 "lam_methname.ml"
+#1 "ast_derive_util.ml"
(* 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
@@ -16432,143 +16996,86 @@ end = struct
* 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. *)
+open Ast_helper
-(**
- {[
- _open -> open
- _in -> in
- _MAX_LENGTH -> MAX_LENGTH
- _Capital -> Capital
-
- _open__ -> _open
- open__ -> open
-
- _'x -> 'x
-
- _Capital__ -> _Capital
- _MAX__ -> _MAX
- __ -> __
- __x -> __x
- ___ -> _
- ____ -> __
- _ -> _ (* error *)
-
-
- ]}
- First we scan '__' from end to start,
- If found, discard it.
- Otherwise, check if it is [_ + keyword] or followed by capital letter,
- If so, discard [_].
+let core_type_of_type_declaration
+ (tdcl : Parsetree.type_declaration) =
+ match tdcl with
+ | {ptype_name = {txt ; loc};
+ ptype_params ;
+ } ->
+ Typ.constr
+ {txt = Lident txt ; loc}
+ (Ext_list.map fst ptype_params)
- Limitations: user can not have [_Capital__, _Capital__other] to
- make it all compile to [Capital].
- Keyword is fine [open__, open__other].
- So we loose polymorphism over capital letter.
- It is okay, otherwise, if [_Captial__] is interpreted as [Capital], then
- there is no way to express [_Capital]
-*)
+let new_type_of_type_declaration
+ (tdcl : Parsetree.type_declaration) newName =
+ match tdcl with
+ | {ptype_name = { loc};
+ ptype_params ;
+ } ->
+ (Typ.constr
+ {txt = Lident newName ; loc}
+ (Ext_list.map fst ptype_params),
+ { Parsetree.ptype_params = tdcl.ptype_params;
+ ptype_name = {txt = newName;loc};
+ ptype_kind = Ptype_abstract;
+ ptype_attributes = [];
+ ptype_loc = tdcl.ptype_loc;
+ ptype_cstrs = []; ptype_private = Public; ptype_manifest = None}
+ )
-(* Copied from [ocaml/parsing/lexer.mll] *)
-let key_words = String_hash_set.of_array [|
- "and";
- "as";
- "assert";
- "begin";
- "class";
- "constraint";
- "do";
- "done";
- "downto";
- "else";
- "end";
- "exception";
- "external";
- "false";
- "for";
- "fun";
- "function";
- "functor";
- "if";
- "in";
- "include";
- "inherit";
- "initializer";
- "lazy";
- "let";
- "match";
- "method";
- "module";
- "mutable";
- "new";
- "nonrec";
- "object";
- "of";
- "open";
- "or";
-(* "parser", PARSER; *)
- "private";
- "rec";
- "sig";
- "struct";
- "then";
- "to";
- "true";
- "try";
- "type";
- "val";
- "virtual";
- "when";
- "while";
- "with";
+
+let lift_string_list_to_array (labels : string list) =
+ Exp.array
+ (Ext_list.map (fun s -> Exp.constant (Const_string (s, None)))
+ labels)
- "mod";
- "land";
- "lor";
- "lxor";
- "lsl";
- "lsr";
- "asr";
-|]
-let double_underscore = "__"
+let lift_int i = Exp.constant (Const_int i)
+let lift_int_list_to_array (labels : int list) =
+ Exp.array (Ext_list.map lift_int labels)
-(*https://caml.inria.fr/pub/docs/manual-ocaml/lex.html
-{[
- label-name ::= lowercase-ident
-]}
-*)
-let valid_start_char x =
- match x with
- | '_' | 'a' .. 'z' -> true
- | _ -> false
-let translate ?loc name =
- assert (not @@ Ext_string.is_empty name);
- let i = Ext_string.rfind ~sub:double_underscore name in
- if i < 0 then
- let name_len = String.length name in
- if name.[0] = '_' then begin
- let try_key_word = (String.sub name 1 (name_len - 1)) in
- if name_len > 1 &&
- (not (valid_start_char try_key_word.[0])
- || String_hash_set.mem key_words try_key_word) then
- try_key_word
- else
- name
- end
- else name
- else if i = 0 then name
- else String.sub name 0 i
+let mk_fun ~loc (typ : Parsetree.core_type)
+ (value : string) body
+ : Parsetree.expression =
+ Exp.fun_
+ "" None
+ (Pat.constraint_ (Pat.var {txt = value ; loc}) typ)
+ body
+let destruct_label_declarations ~loc
+ (arg_name : string)
+ (labels : Parsetree.label_declaration list) :
+ (Parsetree.core_type * Parsetree.expression) list * string list
+ =
+ Ext_list.fold_right
+ (fun ({pld_name = {txt}; pld_type} : Parsetree.label_declaration)
+ (core_type_exps, labels) ->
+ ((pld_type,
+ Exp.field (Exp.ident {txt = Lident arg_name ; loc})
+ {txt = Lident txt ; loc}) :: core_type_exps),
+ txt :: labels
+ ) labels ([], [])
+let notApplicable
+ loc derivingName =
+ Location.prerr_warning
+ loc
+ (Warnings.Bs_derive_warning ( derivingName ^ " not applicable to this type"))
+
+let invalid_config (config : Parsetree.expression) =
+ Location.raise_errorf ~loc:config.pexp_loc "such configuration is not supported"
+
end
-module External_process : sig
-#1 "external_process.mli"
-(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+module Ast_derive_abstract : sig
+#1 "ast_derive_abstract.mli"
+(* Copyright (C) 2017 Authors of BuckleScript
*
* 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
@@ -16592,41 +17099,14 @@ module External_process : sig
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
+val handleTdclsInStr :
+ Parsetree.type_declaration list -> Parsetree.structure
-
-
-
-(**
- [handle_attributes_as_string
- loc pval_name.txt pval_type pval_attributes pval_prim]
- [pval_name.txt] is the name of identifier
- [pval_prim] is the name of string literal
-
- return value is of [pval_type, pval_prims, new_attrs]
-*)
-val handle_attributes_as_string :
- Bs_loc.t ->
- string ->
- Ast_core_type.t ->
- Ast_attributes.t ->
- string ->
- Ast_core_type.t * string list * Ast_attributes.t
-
-
-
-
-(** [pval_prim_of_labels labels]
- return [pval_prims] for FFI, it is specialized for
- external object which is used in
- {[ [%obj { x = 2; y = 1} ] ]}
-*)
-val pval_prim_of_labels : string Asttypes.loc list -> string list
-
-
-
+val handleTdclsInSig:
+ Parsetree.type_declaration list -> Parsetree.signature
end = struct
-#1 "external_process.ml"
-(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+#1 "ast_derive_abstract.ml"
+(* Copyright (C) 2017 Authors of BuckleScript
*
* 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
@@ -16651,978 +17131,1529 @@ end = struct
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-[@@@ocaml.warning "+9"]
-
-
+let derivingName = "abstract"
+module U = Ast_derive_util
+open Ast_helper
+type tdcls = Parsetree.type_declaration list
-let variant_can_bs_unwrap_fields row_fields =
- let validity =
- List.fold_left
- begin fun st row ->
- match st, row with
- | (* we've seen no fields or only valid fields so far *)
- (`No_fields | `Valid_fields),
- (* and this field has one constructor arg that we can unwrap to *)
- Parsetree.Rtag (label, attrs, false, ([ _ ]))
- ->
- `Valid_fields
- | (* otherwise, this field or a previous field was invalid *)
- _ ->
- `Invalid_field
- end
- `No_fields
- row_fields
- in
- match validity with
- | `Valid_fields -> true
- | `No_fields
- | `Invalid_field -> false
+let handle_config (config : Parsetree.expression option) =
+ match config with
+ | Some config ->
+ U.invalid_config config
+ | None -> ()
+(* see #2337
+ TODO: relax it to allow (int -> int [@bs])
+*)
+let rec checkNotFunciton (ty : Parsetree.core_type) =
+ match ty.ptyp_desc with
+ | Ptyp_poly (_,ty) -> checkNotFunciton ty
+ | Ptyp_alias (ty,_) -> checkNotFunciton ty
+ | Ptyp_arrow _ ->
+ Location.raise_errorf
+ ~loc:ty.ptyp_loc
+ "syntactic function type is not allowed when working with abstract bs.deriving, create a named type as work around"
+ | Ptyp_any
+ | Ptyp_var _
+ | Ptyp_tuple _
+ | Ptyp_constr _
+ | Ptyp_object _
+ | Ptyp_class _
+ | Ptyp_variant _
+ | Ptyp_package _
+ | Ptyp_extension _ -> ()
+let handleTdcl (tdcl : Parsetree.type_declaration) =
+ let core_type = U.core_type_of_type_declaration tdcl in
+ let loc = tdcl.ptype_loc in
+ let name = tdcl.ptype_name.txt in
+ let newTdcl = {
+ tdcl with
+ ptype_kind = Ptype_abstract;
+ ptype_attributes = [];
+ (* avoid non-terminating*)
+ } in
+ match tdcl.ptype_kind with
+ | Ptype_record label_declarations ->
+ let ty =
+ Ext_list.fold_right (fun (label_declaration : Parsetree.label_declaration) acc ->
+ Typ.arrow
+ label_declaration.pld_name.txt label_declaration.pld_type acc
+ ) label_declarations core_type in
+ let setter_accessor =
+ Ext_list.fold_right (fun (x: Parsetree.label_declaration) acc ->
+ let pld_name = x.pld_name.txt in
+ let pld_loc = x.pld_name.loc in
+ let pld_type = x.pld_type in
+ let () = checkNotFunciton pld_type in
+ let setter =
+ Val.mk
+ {loc = pld_loc; txt = pld_name}
+ ~attrs:[Ast_attributes.bs_get]
+ ~prim:[pld_name]
+ (Typ.arrow "" core_type pld_type) :: acc in
+ match x.pld_mutable with
+ | Mutable ->
+ Val.mk
+ {loc = pld_loc; txt = pld_name ^ "Set"}
+ ~attrs:[Ast_attributes.bs_set]
+ ~prim:[pld_name]
+ (Typ.arrow "" core_type (Typ.arrow "" pld_type (Ast_literal.type_unit ()))) :: setter
+ | Immutable -> setter
+ ) label_declarations []
+ in
-(** Given the type of argument, process its [bs.] attribute and new type,
- The new type is currently used to reconstruct the external type
- and result type in [@@bs.obj]
- They are not the same though, for example
- {[
- external f : hi:([ `hi | `lo ] [@bs.string]) -> unit -> _ = "" [@@bs.obj]
- ]}
- The result type would be [ hi:string ]
-*)
-let get_arg_type ~nolabel optional
- (ptyp : Ast_core_type.t) :
- External_arg_spec.attr * Ast_core_type.t =
- let ptyp = if optional then Ast_core_type.extract_option_type_exn ptyp else ptyp in
- if Ast_core_type.is_any ptyp then (* (_[@bs.as ])*)
- if optional then
- Bs_syntaxerr.err ptyp.ptyp_loc Invalid_underscore_type_in_external
- else begin
- let ptyp_attrs =
- ptyp.Parsetree.ptyp_attributes
- in
- let result =
- Ast_attributes.iter_process_bs_string_or_int_as ptyp_attrs
- in
- (* when ppx start dropping attributes
- we should warn, there is a trade off whether
- we should warn dropped non bs attribute or not
- *)
- Bs_ast_invariant.warn_unused_attributes ptyp_attrs;
- match result with
- | None ->
- Bs_syntaxerr.err ptyp.ptyp_loc Invalid_underscore_type_in_external
+ newTdcl,
+ (match tdcl.ptype_private with
+ | Private -> setter_accessor
+ | Public ->
+ let maker =
+ Val.mk {loc; txt = name}
+ ~attrs:[Ast_attributes.bs_obj]
+ ~prim:[""] ty in
+ (maker :: setter_accessor))
- | Some (`Int i) ->
- Arg_cst(External_arg_spec.cst_int i), Ast_literal.type_int ~loc:ptyp.ptyp_loc ()
- | Some (`Str i)->
- Arg_cst (External_arg_spec.cst_string i), Ast_literal.type_string ~loc:ptyp.ptyp_loc ()
- | Some (`Json_str s) ->
- Arg_cst (External_arg_spec.cst_json ptyp.ptyp_loc s),
- Ast_literal.type_string ~loc:ptyp.ptyp_loc ()
+ | Ptype_abstract
+ | Ptype_variant _
+ | Ptype_open ->
+ (* Looks obvious that it does not make sense to warn *)
+ (* U.notApplicable tdcl.ptype_loc derivingName; *)
+ tdcl, []
- end
- else (* ([`a|`b] [@bs.string]) *)
- let ptyp_desc = ptyp.ptyp_desc in
- match Ast_attributes.process_bs_string_int_unwrap_uncurry ptyp.ptyp_attributes with
- | (`String, ptyp_attributes)
- ->
- begin match ptyp_desc with
- | Ptyp_variant ( row_fields, Closed, None)
- ->
- let attr =
- Ast_polyvar.map_row_fields_into_strings ptyp.ptyp_loc row_fields in
- attr,
- {ptyp with
- ptyp_attributes
- }
- | _ ->
- Bs_syntaxerr.err ptyp.ptyp_loc Invalid_bs_string_type
- end
- | (`Ignore, ptyp_attributes) ->
- (Ignore, {ptyp with ptyp_attributes})
- | (`Int , ptyp_attributes) ->
- begin match ptyp_desc with
- | Ptyp_variant ( row_fields, Closed, None) ->
- let int_lists =
- Ast_polyvar.map_row_fields_into_ints ptyp.ptyp_loc row_fields in
- Int int_lists ,
- {ptyp with
- ptyp_attributes
- }
- | _ -> Bs_syntaxerr.err ptyp.ptyp_loc Invalid_bs_int_type
- end
- | (`Unwrap, ptyp_attributes) ->
+let handleTdclsInStr tdcls =
+ let tdcls, code =
+ List.fold_right (fun tdcl (tdcls, sts) ->
+ match handleTdcl tdcl with
+ ntdcl, value_descriptions ->
+ ntdcl::tdcls,
+ Ext_list.map_append (fun x -> Str.primitive x) value_descriptions sts
- begin match ptyp_desc with
- | (Ptyp_variant (row_fields, Closed, _) as ptyp_desc)
- when variant_can_bs_unwrap_fields row_fields ->
- Unwrap, {ptyp with ptyp_desc; ptyp_attributes}
- | _ ->
- Bs_syntaxerr.err ptyp.ptyp_loc Invalid_bs_unwrap_type
- end
- | (`Uncurry opt_arity, ptyp_attributes) ->
- let real_arity = Ast_core_type.get_uncurry_arity ptyp in
- (begin match opt_arity, real_arity with
- | Some arity, `Not_function ->
- Fn_uncurry_arity arity
- | None, `Not_function ->
- Bs_syntaxerr.err ptyp.ptyp_loc Canot_infer_arity_by_syntax
- | None, `Arity arity ->
- Fn_uncurry_arity arity
- | Some arity, `Arity n ->
- if n <> arity then
- Bs_syntaxerr.err ptyp.ptyp_loc (Inconsistent_arity (arity,n))
- else Fn_uncurry_arity arity
+ ) tdcls ([],[]) in
+ Str.type_ tdcls :: code
+(* still need perform transformation for non-abstract type*)
- end, {ptyp with ptyp_attributes})
- | (`Nothing, ptyp_attributes) ->
- begin match ptyp_desc with
- | Ptyp_constr ({txt = Lident "bool"; _}, [])
- ->
- Bs_warnings.prerr_bs_ffi_warning ptyp.ptyp_loc Unsafe_ffi_bool_type;
- Nothing
- | Ptyp_constr ({txt = Lident "unit"; _}, [])
- -> if nolabel then Extern_unit else Nothing
- | Ptyp_constr ({txt = Lident "array"; _}, [_])
- -> Array
- | Ptyp_variant _ ->
- Bs_warnings.prerr_bs_ffi_warning ptyp.ptyp_loc Unsafe_poly_variant_type;
- Nothing
- | _ ->
- Nothing
- end, ptyp
+let handleTdclsInSig tdcls =
+ let tdcls, code =
+ List.fold_right (fun tdcl (tdcls, sts) ->
+ match handleTdcl tdcl with
+ ntdcl, value_descriptions ->
+ ntdcl::tdcls,
+ Ext_list.map_append (fun x -> Sig.value x) value_descriptions sts
+ ) tdcls ([],[]) in
+ Sig.type_ tdcls :: code
+end
+module Ast_derive_js_mapper : sig
+#1 "ast_derive_js_mapper.mli"
+(* Copyright (C) 2017 Authors of BuckleScript
+ *
+ * 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. *)
-(**
- [@@bs.module "react"]
- [@@bs.module "react"]
- ---
- [@@bs.module "@" "react"]
- [@@bs.module "@" "react"]
- They should have the same module name
+val init : unit -> unit
+end = struct
+#1 "ast_derive_js_mapper.ml"
+(* Copyright (C) 2017 Authors of BuckleScript
+ *
+ * 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. *)
- TODO: we should emit an warning if we bind
- two external files to the same module name
-*)
-type bundle_source =
- [`Nm_payload of string (* from payload [@@bs.val "xx" ]*)
- |`Nm_external of string (* from "" in external *)
- | `Nm_val of string (* from function name *)
- ]
+open Ast_helper
+module U = Ast_derive_util
+type tdcls = Parsetree.type_declaration list
-let string_of_bundle_source (x : bundle_source) =
- match x with
- | `Nm_payload x
- | `Nm_external x
- | `Nm_val x -> x
-type name_source =
- [ bundle_source
- | `Nm_na
+let js_field (o : Parsetree.expression) m =
+ Exp.apply
+ (Exp.ident {txt = Lident "##"; loc = o.pexp_loc})
+ [
+ "",o;
+ "", Exp.ident m
+ ]
+let const_int i = Exp.constant (Const_int i)
+let const_string s = Exp.constant (Const_string (s,None))
- ]
+let handle_config (config : Parsetree.expression option) =
+ match config with
+ | Some config ->
+ (match config.pexp_desc with
+ | Pexp_record (
+ [
+ {txt = Lident "newType"},
+ {pexp_desc =
+ (Pexp_construct
+ (
+ {txt =
+ Lident ("true"
+ | "false"
+ as x)}, None)
+ | Pexp_ident {txt = Lident ("newType" as x)}
+ )
+ }
+ ],None)
+ -> not (x = "false")
+ | Pexp_ident {txt = Lident ("newType")}
+ -> true
+ | _ -> U.invalid_config config)
+ | None -> false
+let noloc = Location.none
+(* [eraseType] will be instrumented, be careful about the name conflict*)
+let eraseTypeLit = "jsMapperEraseType"
+let eraseTypeExp = Exp.ident {loc = noloc; txt = Lident eraseTypeLit}
+let eraseType x =
+ Exp.apply eraseTypeExp ["", x]
+let eraseTypeStr =
+ let any = Typ.any () in
+ Str.primitive
+ (Val.mk ~prim:["%identity"] {loc = noloc; txt = eraseTypeLit}
+ (Typ.arrow "" any any)
+ )
+
+let app2 f arg1 arg2 =
+ Exp.apply f ["",arg1; "", arg2]
+let app3 f arg1 arg2 arg3 =
+ Exp.apply f ["", arg1; "", arg2; "", arg3]
+let (<=~) a b =
+ app2 (Exp.ident {loc = noloc; txt = Lident "<="}) a b
+let (-~) a b =
+ app2 (Exp.ident {loc = noloc; txt = Ldot(Lident "Pervasives","-")})
+ a b
+let (+~) a b =
+ app2 (Exp.ident {loc = noloc; txt = Ldot(Lident "Pervasives","+")})
+ a b
+let (&&~) a b =
+ app2 (Exp.ident {loc = noloc; txt = Ldot(Lident "Pervasives","&&")})
+ a b
+let (->~) a b = Typ.arrow "" a b
+let jsMapperRt =
+ Longident.Ldot (Lident "Js", "MapperRt")
+
+let search upper polyvar array =
+ app3
+ (Exp.ident ({loc = noloc;
+ txt = Longident.Ldot (jsMapperRt,"binarySearch") })
+ )
+ upper
+ (eraseType polyvar)
+ array
+let revSearch len constantArray exp =
+ app3
+ (Exp.ident
+ {loc= noloc;
+ txt = Longident.Ldot (jsMapperRt, "revSearch")})
+ len
+ constantArray
+ exp
+let revSearchAssert len constantArray exp =
+ app3
+ (Exp.ident
+ {loc= noloc;
+ txt = Longident.Ldot (jsMapperRt, "revSearchAssert")})
+ len
+ constantArray
+ exp
-type st =
- { val_name : name_source;
- external_module_name : External_ffi_types.external_module_name option;
- module_as_val : External_ffi_types.external_module_name option;
- val_send : name_source ;
- val_send_pipe : Ast_core_type.t option;
- splice : bool ; (* mutable *)
- scopes : string list ;
- set_index : bool; (* mutable *)
- get_index : bool;
- new_name : name_source ;
- call_name : name_source ;
- set_name : name_source ;
- get_name : name_source ;
+let toInt exp array =
+ app2
+ (Exp.ident
+ { loc=noloc;
+ txt = Longident.Ldot (jsMapperRt, "toInt")})
+ (eraseType exp)
+ array
+let fromInt len array exp =
+ app3
+ (Exp.ident
+ {loc = noloc;
+ txt = Longident.Ldot (jsMapperRt,"fromInt")})
+ len
+ array
+ exp
+
+let fromIntAssert len array exp =
+ app3
+ (Exp.ident
+ {loc = noloc;
+ txt = Longident.Ldot (jsMapperRt,"fromIntAssert")})
+ len
+ array
+ exp
- mk_obj : bool ;
- return_wrapper : External_ffi_types.return_wrapper ;
- }
+let assertExp e =
+ Exp.extension
+ ({Asttypes.loc = noloc; txt = "assert"},
+ (PStr
+ [Str.eval e ]
+ )
+ )
+let derivingName = "jsConverter"
-let init_st =
- {
- val_name = `Nm_na;
- external_module_name = None ;
- module_as_val = None;
- val_send = `Nm_na;
- val_send_pipe = None;
- splice = false;
- scopes = [];
- set_index = false;
- get_index = false;
- new_name = `Nm_na;
- call_name = `Nm_na;
- set_name = `Nm_na ;
- get_name = `Nm_na ;
- mk_obj = false ;
- return_wrapper = Return_unset;
+(* let notApplicable loc =
+ Location.prerr_warning
+ loc
+ (Warnings.Bs_derive_warning ( derivingName ^ " not applicable to this type")) *)
- }
+let init () =
+ Ast_derive.register
+ derivingName
+ (fun ( x : Parsetree.expression option) ->
+ let createType = handle_config x in
+
+ {
+ structure_gen = (fun (tdcls : tdcls) _ ->
+ let handle_tdcl (tdcl: Parsetree.type_declaration) =
+ let core_type = U.core_type_of_type_declaration tdcl
+ in
+ let name = tdcl.ptype_name.txt in
+ let toJs = name ^ "ToJs" in
+ let fromJs = name ^ "FromJs" in
+ let constantArray = "jsMapperConstantArray" in
+ let loc = tdcl.ptype_loc in
+ let patToJs = {Asttypes.loc; txt = toJs} in
+ let patFromJs = {Asttypes.loc; txt = fromJs} in
+ let param = "param" in
+
+ let ident_param = {Asttypes.txt = Longident.Lident param; loc} in
+ let pat_param = {Asttypes.loc; txt = param} in
+ let exp_param = Exp.ident ident_param in
+ let newType,newTdcl =
+ U.new_type_of_type_declaration tdcl ("abs_" ^ name) in
+ let newTypeStr = Str.type_ [newTdcl] in
+ let toJsBody body =
+ Ast_comb.single_non_rec_value patToJs
+ (Exp.fun_ "" None (Pat.constraint_ (Pat.var pat_param) core_type)
+ body )
+ in
+ let (+>) a ty =
+ Exp.constraint_ (eraseType a) ty in
+ let (+:) a ty =
+ eraseType (Exp.constraint_ a ty) in
+ let coerceResultToNewType e =
+ if createType then
+ e +> newType
+ else e
+ in
+ match tdcl.ptype_kind with
+ | Ptype_record label_declarations ->
+ let exp =
+ coerceResultToNewType
+ (Exp.extension
+ (
+ {Asttypes.loc; txt = "bs.obj"},
+ (PStr
+ [Str.eval
+ (Exp.record
+ (List.map
+ (fun ({pld_name = {loc; txt } } : Parsetree.label_declaration) ->
+ let label =
+ {Asttypes.loc; txt = Longident.Lident txt } in
+ label,Exp.field exp_param label
+ ) label_declarations) None)]))) in
+ let toJs =
+ toJsBody exp
+ in
+ let obj_exp =
+ Exp.record
+ (List.map
+ (fun ({pld_name = {loc; txt } } : Parsetree.label_declaration) ->
+ let label =
+ {Asttypes.loc; txt = Longident.Lident txt } in
+ label,
+ js_field exp_param label
+ ) label_declarations) None in
+ let fromJs =
+ Ast_comb.single_non_rec_value patFromJs
+ (Exp.fun_ "" None (Pat.var pat_param)
+ (if createType then
+ (Exp.let_ Nonrecursive
+ [Vb.mk
+ (Pat.var pat_param)
+ (exp_param +: newType)]
+ (Exp.constraint_ obj_exp core_type) )
+ else
+ (Exp.constraint_ obj_exp core_type) ))
+ in
+ let rest =
+ [
+ toJs;
+ fromJs
+ ] in
+ if createType then eraseTypeStr:: newTypeStr :: rest else rest
+ | Ptype_abstract ->
+ (match Ast_polyvar.is_enum_polyvar tdcl with
+ | Some row_fields ->
+ let attr =
+ Ast_polyvar.map_row_fields_into_strings loc row_fields
+ in
+ let expConstantArray =
+ Exp.ident {loc; txt = Longident.Lident constantArray} in
+ begin match attr with
+ | NullString result ->
+ let result_len = List.length result in
+ let exp_len = const_int result_len in
+ let v = [
+ eraseTypeStr;
+ Ast_comb.single_non_rec_value
+ {loc; txt = constantArray}
+ (Exp.array
+ (List.map (fun (i,str) ->
+ Exp.tuple
+ [
+ const_int i;
+ const_string str
+ ]
+ ) (List.sort (fun (a,_) (b,_) -> compare (a:int) b) result)));
+ (
+ toJsBody
+ (coerceResultToNewType
+ (search
+ exp_len
+ exp_param
+ expConstantArray
+ ))
+ );
+ Ast_comb.single_non_rec_value
+ patFromJs
+ (Exp.fun_ "" None
+ (Pat.var pat_param)
+ (if createType then
+ revSearchAssert
+ exp_len
+ expConstantArray
+ (exp_param +: newType)
+ +>
+ core_type
+ else
+ revSearch
+ exp_len
+ expConstantArray
+ exp_param
+ +>
+ Ast_core_type.lift_option_type core_type
+ )
+ )
+ ] in
+ if createType then
+ newTypeStr :: v
+ else v
+ | _ -> assert false
+ end
+ | None ->
+ U.notApplicable
+ tdcl.Parsetree.ptype_loc
+ derivingName;
+ []
+ )
+
+ | Ptype_variant ctors ->
+ if Ast_polyvar.is_enum_constructors ctors then
+ let xs = Ast_polyvar.map_constructor_declarations_into_ints ctors in
+ match xs with
+ | `New xs ->
+ let constantArrayExp = Exp.ident {loc; txt = Lident constantArray} in
+ let exp_len = const_int (List.length ctors) in
+ let v = [
+ eraseTypeStr;
+ Ast_comb.single_non_rec_value
+ {loc; txt = constantArray}
+ (Exp.array (List.map (fun i -> const_int i) xs ))
+ ;
+ toJsBody
+ (
+ coerceResultToNewType @@
+ toInt
+ exp_param
+ constantArrayExp
+ )
+ ;
+ Ast_comb.single_non_rec_value
+ patFromJs
+ (Exp.fun_ "" None
+ (Pat.var pat_param)
+ (
+ if createType then
+ fromIntAssert
+ exp_len
+ constantArrayExp
+ (exp_param +: newType)
+ +>
+ core_type
+ else
+ fromInt
+ exp_len
+ constantArrayExp
+ exp_param
+ +>
+ Ast_core_type.lift_option_type core_type
+ )
+ )
+ ] in
+ if createType then newTypeStr :: v else v
+ | `Offset offset ->
+ let v =
+ [ eraseTypeStr;
+ toJsBody (
+ coerceResultToNewType
+ (eraseType exp_param +~ const_int offset)
+ )
+ ;
+ let len = List.length ctors in
+ let range_low = const_int (offset + 0) in
+ let range_upper = const_int (offset + len - 1) in
+ Ast_comb.single_non_rec_value
+ {loc ; txt = fromJs}
+ (Exp.fun_ "" None
+ (Pat.var pat_param)
+ (if createType then
+ (Exp.let_ Nonrecursive
+ [Vb.mk
+ (Pat.var pat_param)
+ (exp_param +: newType)
+ ]
+ (
+ Exp.sequence
+ (assertExp
+ ((exp_param <=~ range_upper) &&~ (range_low <=~ exp_param))
+ )
+ (exp_param -~ const_int offset))
+ )
+ +>
+ core_type
+ else
+ (Exp.ifthenelse
+ ( (exp_param <=~ range_upper) &&~ (range_low <=~ exp_param))
+ (Exp.construct {loc; txt = Lident "Some"}
+ ( Some (exp_param -~ const_int offset)))
+ (Some (Exp.construct {loc; txt = Lident "None"} None)))
+ +>
+ Ast_core_type.lift_option_type core_type
+ )
+ )
+ ] in
+ if createType then newTypeStr :: v else v
+ else
+ begin
+ U.notApplicable
+ tdcl.Parsetree.ptype_loc
+ derivingName;
+ []
+ end
+ | Ptype_open ->
+ U.notApplicable tdcl.Parsetree.ptype_loc
+ derivingName;
+ [] in
+ Ext_list.flat_map handle_tdcl tdcls
+ );
+ signature_gen =
+ (fun (tdcls : tdcls) _ ->
+ let handle_tdcl tdcl =
+ let core_type = U.core_type_of_type_declaration tdcl
+ in
+ let name = tdcl.ptype_name.txt in
+ let toJs = name ^ "ToJs" in
+ let fromJs = name ^ "FromJs" in
+ let loc = tdcl.ptype_loc in
+ let patToJs = {Asttypes.loc; txt = toJs} in
+ let patFromJs = {Asttypes.loc; txt = fromJs} in
+ let toJsType result =
+ Ast_comb.single_non_rec_val patToJs (Typ.arrow "" core_type result) in
+ let newType,newTdcl =
+ U.new_type_of_type_declaration tdcl ("abs_" ^ name) in
+ let newTypeStr = Sig.type_ [newTdcl] in
+ let (+?) v rest = if createType then v :: rest else rest in
+ match tdcl.ptype_kind with
+ | Ptype_record label_declarations ->
+ let objType flag =
+ Ast_comb.to_js_type loc @@
+ Typ.object_
+ (List.map
+ (fun ({pld_name = {loc; txt }; pld_type } : Parsetree.label_declaration) ->
+ txt, [], pld_type
+ ) label_declarations)
+ flag in
+ newTypeStr +?
+ [
+ toJsType (if createType then newType else objType Closed);
+ Ast_comb.single_non_rec_val patFromJs
+ ( (if createType then newType else objType Open)->~ core_type)
+ ]
+ | Ptype_abstract ->
+ (match Ast_polyvar.is_enum_polyvar tdcl with
+ | Some _ ->
+ let ty1 =
+ if createType then newType else
+ (Ast_literal.type_string ()) in
+ let ty2 =
+ if createType then core_type
+ else Ast_core_type.lift_option_type core_type in
+ newTypeStr +?
+ [
+ toJsType ty1;
+ Ast_comb.single_non_rec_val
+ patFromJs
+ (ty1 ->~ ty2)
+ ]
-let process_external_attributes
- no_arguments
- (prim_name_or_pval_prim: [< bundle_source ] as 'a)
- pval_prim
- (prim_attributes : Ast_attributes.t) : _ * Ast_attributes.t =
+ | None ->
+ U.notApplicable tdcl.Parsetree.ptype_loc
+ derivingName;
+ [])
- (* shared by `[@@bs.val]`, `[@@bs.send]`,
- `[@@bs.set]`, `[@@bs.get]` , `[@@bs.new]`
- `[@@bs.send.pipe]` does not use it
- *)
- let name_from_payload_or_prim ~loc (payload : Parsetree.payload) : name_source =
- match payload with
- | PStr [] ->
- (prim_name_or_pval_prim :> name_source)
- (* It is okay to have [@@bs.val] without payload *)
- | _ ->
- begin match Ast_payload.is_single_string payload with
- | Some (val_name, _) -> `Nm_payload val_name
- | None ->
- Location.raise_errorf ~loc "Invalid payload"
- end
+ | Ptype_variant ctors
+ ->
- in
- List.fold_left
- (fun (st, attrs)
- (({txt ; loc}, payload) as attr : Ast_attributes.attr)
- ->
- if Ext_string.starts_with txt "bs." then
- begin match txt with
- | "bs.val" ->
- if no_arguments then
- {st with val_name = name_from_payload_or_prim ~loc payload}
- else
- {st with call_name = name_from_payload_or_prim ~loc payload}
+ if Ast_polyvar.is_enum_constructors ctors then
+ let ty1 =
+ if createType then newType
+ else Ast_literal.type_int() in
+ let ty2 =
+ if createType then core_type
+ else Ast_core_type.lift_option_type core_type in
+ newTypeStr +?
+ [
+ toJsType ty1;
+ Ast_comb.single_non_rec_val
+ patFromJs
+ (ty1 ->~ ty2)
+ ]
- | "bs.module" ->
- begin match Ast_payload.assert_strings loc payload with
- | [bundle] ->
- {st with external_module_name =
- Some {bundle; module_bind_name = Phint_nothing}}
- | [bundle;bind_name] ->
- {st with external_module_name =
- Some {bundle; module_bind_name = Phint_name bind_name}}
- | [] ->
- { st with
- module_as_val =
- Some
- { bundle =
- string_of_bundle_source
- (prim_name_or_pval_prim :> bundle_source) ;
- module_bind_name = Phint_nothing}
- }
- | _ ->
- Bs_syntaxerr.err loc Illegal_attribute
- end
- | "bs.scope" ->
- begin match Ast_payload.assert_strings loc payload with
- | [] ->
- Bs_syntaxerr.err loc Illegal_attribute
- (* We need err on empty scope, so we can tell the difference
- between unset/set
- *)
- | scopes -> { st with scopes = scopes }
- end
- | "bs.splice" -> {st with splice = true}
- | "bs.send" ->
- { st with val_send = name_from_payload_or_prim ~loc payload}
- | "bs.send.pipe"
- ->
- { st with val_send_pipe = Some (Ast_payload.as_core_type loc payload)}
- | "bs.set" ->
- {st with set_name = name_from_payload_or_prim ~loc payload}
- | "bs.get" -> {st with get_name = name_from_payload_or_prim ~loc payload}
+ else
+ begin
+ U.notApplicable tdcl.Parsetree.ptype_loc
+ derivingName;
+ []
+ end
+ | Ptype_open ->
+ U.notApplicable tdcl.Parsetree.ptype_loc
+ derivingName;
+ [] in
+ Ext_list.flat_map handle_tdcl tdcls
- | "bs.new" -> {st with new_name = name_from_payload_or_prim ~loc payload}
- | "bs.set_index" -> {st with set_index = true}
- | "bs.get_index"-> {st with get_index = true}
- | "bs.obj" -> {st with mk_obj = true}
- | "bs.return" ->
- let aux loc txt : External_ffi_types.return_wrapper =
- begin match txt with
- | "undefined_to_opt" -> Return_undefined_to_opt
- | "null_to_opt" -> Return_null_to_opt
- | "nullable"
- | "null_undefined_to_opt" -> Return_null_undefined_to_opt
- | "identity" -> Return_identity
- | _ ->
- Bs_syntaxerr.err loc Not_supported_directive_in_bs_return
- end in
- let actions =
- Ast_payload.ident_or_record_as_config loc payload
- in
- begin match actions with
- | [ ({txt; _ },None) ] ->
- { st with return_wrapper = aux loc txt}
- | _ ->
- Bs_syntaxerr.err loc Not_supported_directive_in_bs_return
- end
- | _ -> (Location.prerr_warning loc (Bs_unused_attribute txt); st)
- end, attrs
- else (st , attr :: attrs)
+ );
+ expression_gen = None
+ }
)
- (init_st, []) prim_attributes
-
-
-let rec has_bs_uncurry (attrs : Ast_attributes.t) =
- match attrs with
- | ({txt = "bs.uncurry"; _ }, _) :: attrs ->
- true
- | _ :: attrs -> has_bs_uncurry attrs
- | [] -> false
-
+;
-let check_return_wrapper
- loc (wrapper : External_ffi_types.return_wrapper)
- result_type =
- match wrapper with
- | Return_identity -> wrapper
- | Return_unset ->
- if Ast_core_type.is_unit result_type then
- Return_replaced_with_unit
- else if Ast_core_type.is_user_bool result_type then
- Return_to_ocaml_bool
- else
- wrapper
- | Return_undefined_to_opt
- | Return_null_to_opt
- | Return_null_undefined_to_opt
- ->
- if Ast_core_type.is_user_option result_type then
- wrapper
- else
- Bs_syntaxerr.err loc Expect_opt_in_bs_return_to_opt
- | Return_replaced_with_unit
- | Return_to_ocaml_bool ->
- assert false (* Not going to happen from user input*)
+end
+module Ast_derive_projector : sig
+#1 "ast_derive_projector.mli"
+(* Copyright (C) 2017 Authors of BuckleScript
+ *
+ * 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 init : unit -> unit
-(** Note that the passed [type_annotation] is already processed by visitor pattern before
-*)
-let handle_attributes
- (loc : Bs_loc.t)
- (pval_prim : string )
- (type_annotation : Parsetree.core_type)
- (prim_attributes : Ast_attributes.t) (prim_name : string)
- : Ast_core_type.t * string * External_ffi_types.t * Ast_attributes.t =
- (** sanity check here
- {[ int -> int -> (int -> int -> int [@bs.uncurry])]}
- It does not make sense
- *)
- if has_bs_uncurry type_annotation.Parsetree.ptyp_attributes then
- begin
- Location.raise_errorf
- ~loc "[@@bs.uncurry] can not be applied to the whole definition"
- end;
+end = struct
+#1 "ast_derive_projector.ml"
+open Ast_helper
- let prim_name_or_pval_prim =
- if String.length prim_name = 0 then `Nm_val pval_prim
- else `Nm_external prim_name (* need check name *)
- in
- let result_type, arg_types_ty =
- Ast_core_type.list_of_arrow type_annotation in
- if has_bs_uncurry result_type.ptyp_attributes then
- begin
- Location.raise_errorf
- ~loc:result_type.ptyp_loc
- "[@@bs.uncurry] can not be applied to tailed position"
- end ;
- let (st, left_attrs) =
- process_external_attributes
- (arg_types_ty = [])
- prim_name_or_pval_prim pval_prim prim_attributes in
+let invalid_config (config : Parsetree.expression) =
+ Location.raise_errorf ~loc:config.pexp_loc "such configuration is not supported"
- if st.mk_obj then
- begin match st with
- | {
- val_name = `Nm_na;
- external_module_name = None ;
- module_as_val = None;
- val_send = `Nm_na;
- val_send_pipe = None;
- splice = false;
- new_name = `Nm_na;
- call_name = `Nm_na;
- set_name = `Nm_na ;
- get_name = `Nm_na ;
- get_index = false ;
- return_wrapper = Return_unset ;
- set_index = false ;
- mk_obj = _;
- scopes = [];
- (* wrapper does not work with [bs.obj]
- TODO: better error message *)
- } ->
- if String.length prim_name <> 0 then
- Location.raise_errorf ~loc "[@@bs.obj] expect external names to be empty string";
- let arg_kinds, new_arg_types_ty, result_types =
- Ext_list.fold_right
- (fun (label,ty,attr,loc) ( arg_labels, arg_types, result_types) ->
- let arg_label = Ast_core_type.label_name label in
- let new_arg_label, new_arg_types, output_tys =
- match arg_label with
- | Empty ->
- let arg_type, new_ty = get_arg_type ~nolabel:true false ty in
- begin match arg_type with
- | Extern_unit ->
- External_arg_spec.empty_kind arg_type, (label,new_ty,attr,loc)::arg_types, result_types
- | _ ->
- Location.raise_errorf ~loc "expect label, optional, or unit here"
- end
- | Label name ->
- let arg_type, new_ty = get_arg_type ~nolabel:false false ty in
- begin match arg_type with
- | Ignore ->
- External_arg_spec.empty_kind arg_type,
- (label,new_ty,attr,loc)::arg_types, result_types
- | Arg_cst i ->
- let s = (Lam_methname.translate ~loc name) in
- {arg_label = External_arg_spec.label s (Some i);
- arg_type },
- arg_types, (* ignored in [arg_types], reserved in [result_types] *)
- ((name , [], new_ty) :: result_types)
- | Nothing | Array ->
- let s = (Lam_methname.translate ~loc name) in
- {arg_label = External_arg_spec.label s None ; arg_type },
- (label,new_ty,attr,loc)::arg_types,
- ((name , [], new_ty) :: result_types)
- | Int _ ->
- let s = Lam_methname.translate ~loc name in
- {arg_label = External_arg_spec.label s None; arg_type},
- (label,new_ty,attr,loc)::arg_types,
- ((name, [], Ast_literal.type_int ~loc ()) :: result_types)
- | NullString _ ->
- let s = Lam_methname.translate ~loc name in
- {arg_label = External_arg_spec.label s None; arg_type},
- (label,new_ty,attr,loc)::arg_types,
- ((name, [], Ast_literal.type_string ~loc ()) :: result_types)
- | Fn_uncurry_arity _ ->
- Location.raise_errorf ~loc
- "The combination of [@@bs.obj], [@@bs.uncurry] is not supported yet"
- | Extern_unit -> assert false
- | NonNullString _
- ->
- Location.raise_errorf ~loc
- "bs.obj label %s does not support such arg type" name
- | Unwrap ->
- Location.raise_errorf ~loc
- "bs.obj label %s does not support [@bs.unwrap] arguments" name
- end
- | Optional name ->
- let arg_type, new_ty_extract = get_arg_type ~nolabel:false true ty in
- let new_ty = Ast_core_type.lift_option_type new_ty_extract in
- begin match arg_type with
- | Ignore ->
- External_arg_spec.empty_kind arg_type,
- (label,new_ty,attr,loc)::arg_types, result_types
- | Nothing | Array ->
- let s = (Lam_methname.translate ~loc name) in
- {arg_label = External_arg_spec.optional s; arg_type},
- (label,new_ty,attr,loc)::arg_types,
- ( (name, [], Ast_comb.to_undefined_type loc new_ty_extract) :: result_types)
- | Int _ ->
- let s = Lam_methname.translate ~loc name in
- {arg_label = External_arg_spec.optional s ; arg_type },
- (label,new_ty,attr,loc)::arg_types,
- ((name, [], Ast_comb.to_undefined_type loc @@ Ast_literal.type_int ~loc ()) :: result_types)
- | NullString _ ->
- let s = Lam_methname.translate ~loc name in
- {arg_label = External_arg_spec.optional s ; arg_type },
- (label,new_ty,attr,loc)::arg_types,
- ((name, [], Ast_comb.to_undefined_type loc @@ Ast_literal.type_string ~loc ()) :: result_types)
- | Arg_cst _
- ->
- Location.raise_errorf ~loc "bs.as is not supported with optional yet"
- | Fn_uncurry_arity _ ->
- Location.raise_errorf ~loc
- "The combination of [@@bs.obj], [@@bs.uncurry] is not supported yet"
- | Extern_unit -> assert false
- | NonNullString _
- ->
- Location.raise_errorf ~loc
- "bs.obj label %s does not support such arg type" name
- | Unwrap ->
- Location.raise_errorf ~loc
- "bs.obj label %s does not support [@bs.unwrap] arguments" name
- end
- in
- (
- new_arg_label::arg_labels,
- new_arg_types,
- output_tys)) arg_types_ty
- ( [], [], []) in
+type tdcls = Parsetree.type_declaration list
+
+let derivingName = "accessors"
+let init () =
+
+ Ast_derive.register
+ derivingName
+ (fun (x : Parsetree.expression option) ->
+ (match x with
+ | Some config -> invalid_config config
+ | None -> ());
+ {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
+ ->
+ label_declarations
+ |> Ext_list.map (
+ 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
+ (Exp.fun_ "" None
+ (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
+ ->
+ constructor_declarations
+ |> Ext_list.map
+ (fun
+ ( {pcd_name = {loc ; txt = con_name} ; pcd_args ; pcd_loc }:
+ Parsetree.constructor_declaration)
+ -> (* TODO: add type annotations *)
+ let little_con_name = String.uncapitalize con_name in
+ let arity = List.length pcd_args 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)
+ core_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 = Longident.Lident (List.hd vars )}
+ else
+ Exp.tuple (Ext_list.map
+ (fun x -> Exp.ident {loc ; txt = Longident.Lident x})
+ vars
+ ) )) core_type
+ in
+ Ext_list.fold_right (fun var b ->
+ Exp.fun_ "" None (Pat.var {loc ; txt = var}) b
+ ) vars exp
+
+ 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 handle_tdcl tdcls
+
+
+ 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
+ ->
+ label_declarations
+ |> Ext_list.map
+ (fun
+ ({pld_name ;
+ pld_type
+ } :
+ Parsetree.label_declaration) ->
+ Ast_comb.single_non_rec_val pld_name (Typ.arrow "" core_type pld_type )
+ )
+ | Ptype_variant constructor_declarations
+ ->
+ constructor_declarations
+ |>
+ Ext_list.map
+ (fun ({pcd_name = {loc ; txt = con_name} ; pcd_args ; pcd_loc }:
+ Parsetree.constructor_declaration)
+ ->
+ Ast_comb.single_non_rec_val {loc ; txt = (String.uncapitalize con_name)}
+ (Ext_list.fold_right
+ (fun x acc -> Typ.arrow "" x acc)
+ pcd_args
+ core_type))
+ | Ptype_open | Ptype_abstract ->
+ Ast_derive_util.notApplicable tdcl.ptype_loc derivingName ;
+ []
+ in
+ Ext_list.flat_map handle_tdcl tdcls
+ end;
+ expression_gen = None
+ }
+ )
- let result =
- if Ast_core_type.is_any result_type then
- Ast_core_type.make_obj ~loc result_types
- else
- snd @@ get_arg_type ~nolabel:true false result_type (* result type can not be labeled *)
- in
- begin
- (
- Ext_list.fold_right (fun (label,ty,attrs,loc) acc ->
- Ast_helper.Typ.arrow ~loc ~attrs label ty acc
- ) new_arg_types_ty result
- ) ,
- prim_name,
- Ffi_obj_create arg_kinds,
- left_attrs
- end
+end
+module Ast_exp_apply : sig
+#1 "ast_exp_apply.mli"
+(* Copyright (C) 2018 Authors of BuckleScript
+ *
+ * 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. *)
- | _ -> Location.raise_errorf ~loc "Attribute found that conflicts with [@@bs.obj]"
- end
+val handle_exp_apply :
+ Parsetree.expression ->
+ Bs_ast_mapper.mapper ->
+ Parsetree.expression ->
+ (Asttypes.label * Parsetree.expression) list ->
+ Parsetree.expression
- else
- let splice = st.splice in
- let arg_type_specs, new_arg_types_ty, arg_type_specs_length =
- Ext_list.fold_right
- (fun (label,ty,attr,loc) (arg_type_specs, arg_types, i) ->
- let arg_label = Ast_core_type.label_name label in
- let arg_label, arg_type, new_arg_types =
- match arg_label with
- | Optional s ->
+end = struct
+#1 "ast_exp_apply.ml"
+(* Copyright (C) 2018 Authors of BuckleScript
+ *
+ * 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 arg_type , new_ty = get_arg_type ~nolabel:false true ty in
- begin match arg_type with
- | NonNullString _ ->
- (* ?x:([`x of int ] [@bs.string]) does not make sense *)
- Location.raise_errorf
- ~loc
- "[@@bs.string] does not work with optional when it has arities in label %s" label
- | _ ->
- External_arg_spec.optional s, arg_type,
- ((label, Ast_core_type.lift_option_type new_ty , attr,loc) :: arg_types) end
- | Label s ->
- begin match get_arg_type ~nolabel:false false ty with
- | (Arg_cst ( i) as arg_type), new_ty ->
- External_arg_spec.label s (Some i), arg_type, arg_types
- | arg_type, new_ty ->
- External_arg_spec.label s None, arg_type, (label, new_ty,attr,loc) :: arg_types
- end
- | Empty ->
- begin match get_arg_type ~nolabel:true false ty with
- | (Arg_cst ( i) as arg_type), new_ty ->
- External_arg_spec.empty_lit i , arg_type, arg_types
- | arg_type, new_ty ->
- External_arg_spec.empty_label, arg_type, (label, new_ty,attr,loc) :: arg_types
- end
- in
- (if i = 0 && splice then
- match arg_type with
- | Array -> ()
- | _ -> Location.raise_errorf ~loc "[@@@@bs.splice] expect the last type to be an array");
- ({ External_arg_spec.arg_label ;
- arg_type
- } :: arg_type_specs,
- new_arg_types,
- if arg_type = Ignore then i
- else i + 1
+open Ast_helper
+
+let handle_exp_apply
+ (e : Parsetree.expression)
+ (self : Bs_ast_mapper.mapper)
+ (fn : Parsetree.expression)
+ (args : (Asttypes.label * Parsetree.expression) list)
+ =
+ let loc = e.pexp_loc in
+ begin match fn with
+ | {pexp_desc =
+ Pexp_apply (
+ {pexp_desc =
+ Pexp_ident {txt = Lident "##" ; loc} ; _},
+ [("", obj) ;
+ ("", {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _} )
+ ]);
+ _} -> (* f##paint 1 2 *)
+ {e with pexp_desc = Ast_util.method_apply loc self obj name args }
+ | {pexp_desc =
+ Pexp_apply (
+ {pexp_desc =
+ Pexp_ident {txt = Lident "#@" ; loc} ; _},
+ [("", obj) ;
+ ("", {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _} )
+ ]);
+ _} -> (* f##paint 1 2 *)
+ {e with pexp_desc = Ast_util.property_apply loc self obj name args }
+
+ | {pexp_desc =
+ Pexp_ident {txt = Lident "##" ; loc} ; _}
+ ->
+ begin match args with
+ | [("", obj) ;
+ ("", {pexp_desc = Pexp_apply(
+ {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _},
+ args
+ ); pexp_attributes = attrs }
+ (* we should warn when we discard attributes *)
)
- ) arg_types_ty
- (match st with
- | {val_send_pipe = Some obj; _ } ->
- let arg_type, new_ty = get_arg_type ~nolabel:true false obj in
- begin match arg_type with
- | Arg_cst _ ->
- Location.raise_errorf ~loc:obj.ptyp_loc "[@bs.as] is not supported in bs.send type "
- | _ ->
- (* more error checking *)
- [External_arg_spec.empty_kind arg_type]
- ,
- ["", new_ty, [], obj.ptyp_loc]
- ,0
- end
+ ] -> (* f##(paint 1 2 ) *)
+ (* gpr#1063 foo##(bar##baz) we should rewrite (bar##baz)
+ first before pattern match.
+ currently the pattern match is written in a top down style.
+ Another corner case: f##(g a b [@bs])
+ *)
+ Bs_ast_invariant.warn_unused_attributes attrs ;
+ {e with pexp_desc = Ast_util.method_apply loc self obj name args}
+ | [("", obj) ;
+ ("",
+ {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _}
+ ) (* f##paint *)
+ ] ->
+ { e with pexp_desc =
+ Ast_util.js_property loc (self.expr self obj) name
+ }
- | {val_send_pipe = None ; _ } -> [],[], 0) in
+ | _ ->
+ Location.raise_errorf ~loc
+ "Js object ## expect syntax like obj##(paint (a,b)) "
+ end
+ (* we can not use [:=] for precedece cases
+ like {[i @@ x##length := 3 ]}
+ is parsed as {[ (i @@ x##length) := 3]}
+ since we allow user to create Js objects in OCaml, it can be of
+ ref type
+ {[
+ let u = object (self)
+ val x = ref 3
+ method setX x = self##x := 32
+ method getX () = !self##x
+ end
+ ]}
+ *)
+ | {pexp_desc =
+ Pexp_ident {txt = Lident ("#=" )}
+ } ->
+ begin match args with
+ | ["",
+ {pexp_desc =
+ Pexp_apply ({pexp_desc = Pexp_ident {txt = Lident "##"}},
+ ["", obj;
+ "", {pexp_desc = Pexp_ident {txt = Lident name}}
+ ]
+ )};
+ "", arg
+ ] ->
+ Exp.constraint_ ~loc
+ { e with
+ pexp_desc =
+ Ast_util.method_apply loc self obj
+ (name ^ Literals.setter_suffix) ["", arg ] }
+ (Ast_literal.type_unit ~loc ())
+ | _ -> Bs_ast_mapper.default_mapper.expr self e
+ end
+ | _ ->
+ begin match
+ Ext_list.exclude_with_val
+ Ast_attributes.is_bs e.pexp_attributes with
+ | false, _ -> Bs_ast_mapper.default_mapper.expr self e
+ | true, pexp_attributes ->
+ {e with pexp_desc = Ast_util.uncurry_fn_apply loc self fn args ;
+ pexp_attributes }
+ end
+ end
- let ffi : External_ffi_types.attr = match st with
- | {set_index = true;
+end
+module Ast_exp_extension : sig
+#1 "ast_exp_extension.mli"
+(* Copyright (C) 2018 Authors of BuckleScript
+ *
+ * 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_name = `Nm_na;
- external_module_name = None ;
- module_as_val = None;
- val_send = `Nm_na;
- val_send_pipe = None;
- splice = false;
- scopes ;
- get_index = false;
- new_name = `Nm_na;
- call_name = `Nm_na;
- set_name = `Nm_na ;
- get_name = `Nm_na ;
- return_wrapper = _;
- mk_obj = _ ;
+val handle_extension :
+ bool ref ->
+ Parsetree.expression ->
+ Bs_ast_mapper.mapper ->
+ Parsetree.extension ->
+ Parsetree.expression
+
+end = struct
+#1 "ast_exp_extension.ml"
+(* Copyright (C) 2018 Authors of BuckleScript
+ *
+ * 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. *)
+open Ast_helper
+
+let handle_extension record_as_js_object e (self : Bs_ast_mapper.mapper)
+ (({txt ; loc} as lid , payload) : Parsetree.extension) =
+ begin match txt with
+ | "bs.raw" | "raw" ->
+ Ast_util.handle_raw loc payload
+ | "bs.re" | "re" ->
+ Exp.constraint_ ~loc
+ (Ast_util.handle_raw ~check_js_regex:true loc payload)
+ (Ast_comb.to_js_re_type loc)
+ | "bs.external" | "external" ->
+ begin match Ast_payload.as_ident payload with
+ | Some {txt = Lident x}
+ -> Ast_util.handle_external loc x
+ (* do we need support [%external gg.xx ]
+
+ {[ Js.Undefined.to_opt (if Js.typeof x == "undefined" then x else Js.Undefined.empty ) ]}
+ *)
+
+ | None | Some _ ->
+ Location.raise_errorf ~loc
+ "external expects a single identifier"
+ end
+ | "bs.time"| "time" ->
+ (
+ match payload with
+ | PStr [{pstr_desc = Pstr_eval (e,_)}] ->
+ let locString =
+ if loc.loc_ghost then
+ "GHOST LOC"
+ else
+ let loc_start = loc.loc_start in
+ let (file, lnum, __) = Location.get_pos_info loc_start in
+ Printf.sprintf "%s %d"
+ file lnum in
+ let e = self.expr self e in
+ Exp.sequence ~loc
+ (Exp.apply ~loc
+ (Exp.ident ~loc {loc;
+ txt =
+ Ldot (Ldot (Lident "Js", "Console"), "timeStart")
+ })
+ ["", Exp.constant ~loc (Const_string (locString,None))]
+ )
+ ( Exp.let_ ~loc Nonrecursive
+ [Vb.mk ~loc (Pat.var ~loc {loc; txt = "timed"}) e ;
+ ]
+ (Exp.sequence ~loc
+ (Exp.apply ~loc
+ (Exp.ident ~loc {loc;
+ txt =
+ Ldot (Ldot (Lident "Js", "Console"), "timeEnd")
+ })
+ ["", Exp.constant ~loc (Const_string (locString,None))]
+ )
+ (Exp.ident ~loc {loc; txt = Lident "timed"})
+ )
+ )
+ | _ ->
+ Location.raise_errorf
+ ~loc "expect a boolean expression in the payload"
+ )
+ | "bs.assert" | "assert" ->
+ (
+ match payload with
+ | PStr [ {pstr_desc = Pstr_eval( e,_)}] ->
+
+ let locString =
+ if loc.loc_ghost then
+ "ASSERT FAILURE"
+ else
+ let loc_start = loc.loc_start in
+ let (file, lnum, cnum) = Location.get_pos_info loc_start in
+ let enum =
+ loc.Location.loc_end.Lexing.pos_cnum -
+ loc_start.Lexing.pos_cnum + cnum in
+ Printf.sprintf "File %S, line %d, characters %d-%d"
+ file lnum cnum enum in
+ let raiseWithString locString =
+ (Exp.apply ~loc
+ (Exp.ident ~loc {loc; txt =
+ Ldot(Ldot (Lident "Js","Exn"),"raiseError")})
+ ["",
+
+ Exp.constant (Const_string (locString,None))
+ ])
+ in
+ (match e.pexp_desc with
+ | Pexp_construct({txt = Lident "false"},None) ->
+ (* The backend will convert [assert false] into a nop later *)
+ if !Clflags.no_assert_false then
+ Exp.assert_ ~loc
+ (Exp.construct ~loc {txt = Lident "false";loc} None)
+ else
+ (raiseWithString locString)
+ | Pexp_constant (Const_string (r, _)) ->
+ if !Clflags.noassert then
+ Exp.assert_ ~loc (Exp.construct ~loc {txt = Lident "true"; loc} None)
+ (* Need special handling to make it type check*)
+ else
+ raiseWithString r
+ | _ ->
+ let e = self.expr self e in
+ if !Clflags.noassert then
+ (* pass down so that it still type check, but the backend will
+ make it a nop
+ *)
+ Exp.assert_ ~loc e
+ else
+ Exp.ifthenelse ~loc
+ (Exp.apply ~loc
+ (Exp.ident {loc ; txt = Ldot(Lident "Pervasives","not")})
+ ["", e]
+ )
+ (raiseWithString locString)
+ None
+ )
+ | _ ->
+ Location.raise_errorf
+ ~loc "expect a boolean expression in the payload"
+ )
+ | "bs.node" | "node" ->
+ let strip s =
+ match s with
+ | "_module" -> "module"
+ | x -> x in
+ begin match Ast_payload.as_ident payload with
+ | Some {txt = Lident
+ ( "__filename"
+ | "__dirname"
+ | "_module"
+ | "require" as name); loc}
+ ->
+ let exp =
+ Ast_util.handle_external loc (strip name) in
+ let typ =
+ Ast_core_type.lift_option_type
+ @@
+ if name = "_module" then
+ Typ.constr ~loc
+ { txt = Ldot (Lident "Node", "node_module") ;
+ loc} []
+ else if name = "require" then
+ (Typ.constr ~loc
+ { txt = Ldot (Lident "Node", "node_require") ;
+ loc} [] )
+ else
+ Ast_literal.type_string ~loc () in
+ Exp.constraint_ ~loc exp typ
+ | Some _ | None ->
+ begin match payload with
+ | PTyp _ ->
+ Location.raise_errorf
+ ~loc "Illegal payload, expect an expression payload instead of type payload"
+ | PPat _ ->
+ Location.raise_errorf
+ ~loc "Illegal payload, expect an expression payload instead of pattern payload"
+ | _ ->
+ Location.raise_errorf
+ ~loc "Illegal payload"
+ end
+
+ end
+ | "bs.debugger"|"debugger" ->
+ {e with pexp_desc = Ast_util.handle_debugger loc payload}
+ | "bs.obj" | "obj" ->
+ begin match payload with
+ | PStr [{pstr_desc = Pstr_eval (e,_)}]
+ ->
+ Ext_ref.non_exn_protect record_as_js_object true
+ (fun () -> self.expr self e )
+ | _ -> Location.raise_errorf ~loc "Expect an expression here"
+ end
+ | _ ->
+ match payload with
+ | PTyp typ when Ext_string.starts_with txt Literals.bs_deriving_dot ->
+ self.expr self (Ast_derive.gen_expression lid typ)
+ | _ ->
+ e (* For an unknown extension, we don't really need to process further*)
+ (* Exp.extension ~loc ~attrs:e.pexp_attributes (
+ self.extension self extension) *)
+ (* Bs_ast_mapper.default_mapper.expr self e *)
+ end
- }
- ->
- if String.length prim_name <> 0 then
- Location.raise_errorf ~loc "[@@bs.set_index] expect external names to be empty string";
- if arg_type_specs_length = 3 then
- Js_set_index {js_set_index_scopes = scopes}
- else
- Location.raise_errorf ~loc "Ill defined attribute [@@bs.set_index](arity of 3)"
+end
+module Ast_tuple_pattern_flatten : sig
+#1 "ast_tuple_pattern_flatten.mli"
+(* Copyright (C) 2018 Authors of BuckleScript
+ *
+ * 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. *)
- | {set_index = true; _}
- ->
- Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.set_index]")
- | {get_index = true;
+val handle_value_bindings :
+ Bs_ast_mapper.mapper ->
+ Parsetree.value_binding list ->
+ Parsetree.value_binding list
+end = struct
+#1 "ast_tuple_pattern_flatten.ml"
+(* Copyright (C) 2018 Authors of BuckleScript
+ *
+ * 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_name = `Nm_na;
- external_module_name = None ;
- module_as_val = None;
- val_send = `Nm_na;
- val_send_pipe = None;
+ type loc = Location.t
- splice = false;
- scopes ;
- new_name = `Nm_na;
- call_name = `Nm_na;
- set_name = `Nm_na ;
- get_name = `Nm_na ;
- set_index = false;
- mk_obj;
- return_wrapper ;
- } ->
- if String.length prim_name <> 0 then
- Location.raise_errorf ~loc "[@@bs.get_index] expect external names to be empty string";
- if arg_type_specs_length = 2 then
- Js_get_index {js_get_index_scopes = scopes}
- else Location.raise_errorf ~loc
- "Ill defined attribute [@@bs.get_index] (arity expected 2 : while %d)" arg_type_specs_length
+ type acc =
+ (Asttypes.override_flag * Longident.t Asttypes.loc * loc *
+ Parsetree.attributes) list
- | {get_index = true; _}
+let rec is_simple_pattern (p : Parsetree.pattern) =
+ match p.ppat_desc with
+ | Ppat_any -> true
+ | Ppat_var _ -> true
+ | Ppat_constraint(p,_) -> is_simple_pattern p
+ | _ -> false
+
+(**
+ destruct such pattern
+ {[ A.B.let open C in (a,b)]}
+*)
+let rec destruct_open
+ (e : Parsetree.expression) (acc : acc)
+ : (acc * Parsetree.expression list) option =
+ match e.pexp_desc with
+ | Pexp_open (flag, lid, cont)
+ ->
+ destruct_open
+ cont
+ ((flag, lid, e.pexp_loc, e.pexp_attributes) :: acc)
+ | Pexp_tuple es -> Some (acc, es)
+ | _ -> None
- ->
- Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.get_index]")
+
+(*
+ [let (a,b) = M.N.(c,d) ]
+ =>
+ [ let a = M.N.c
+ and b = M.N.d ]
+*)
+let flattern_tuple_pattern_vb
+ (self : Bs_ast_mapper.mapper)
+ ({pvb_loc } as vb : Parsetree.value_binding)
+ acc : Parsetree.value_binding list =
+ let pvb_pat = self.pat self vb.pvb_pat in
+ let pvb_expr = self.expr self vb.pvb_expr in
+ let pvb_attributes = self.attributes self vb.pvb_attributes in
+ match destruct_open pvb_expr [] , pvb_pat.ppat_desc with
+ | Some (wholes, es), Ppat_tuple xs
+ when
+ List.for_all is_simple_pattern xs &&
+ Ext_list.same_length es xs
+ ->
+ (Ext_list.fold_right2 (fun pat exp acc->
+ {Parsetree.
+ pvb_pat =
+ pat;
+ pvb_expr =
+ ( match wholes with
+ | [] -> exp
+ | _ ->
+ List.fold_left (fun x (flag,lid,loc,attrs) ->
+ {Parsetree.
+ pexp_desc = Pexp_open(flag,lid,x);
+ pexp_attributes = attrs;
+ pexp_loc = loc
+ }
+ ) exp wholes) ;
+ pvb_attributes;
+ pvb_loc ;
+ } :: acc
+ ) xs es) acc
+ | _ ->
+ {pvb_pat ;
+ pvb_expr ;
+ pvb_loc ;
+ pvb_attributes} :: acc
+let handle_value_bindings =
+ fun self (vbs : Parsetree.value_binding list) ->
+ (* Bs_ast_mapper.default_mapper.value_bindings self vbs *)
+ List.fold_right (fun vb acc ->
+ flattern_tuple_pattern_vb self vb acc
+ ) vbs []
+end
+module Ext_char : sig
+#1 "ext_char.mli"
+(* 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_as_val = Some external_module_name ;
- get_index = false;
- val_name ;
- new_name ;
- external_module_name = None ;
- val_send = `Nm_na;
- val_send_pipe = None;
- scopes = []; (* module as var does not need scopes *)
- splice;
- call_name = `Nm_na;
- set_name = `Nm_na ;
- get_name = `Nm_na ;
- set_index = false;
- return_wrapper = _;
- mk_obj = _ ;
- } ->
- begin match arg_types_ty, new_name, val_name with
- | [], `Nm_na, _ -> Js_module_as_var external_module_name
- | _, `Nm_na, _ -> Js_module_as_fn {splice; external_module_name }
- | _, #bundle_source, #bundle_source ->
- Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.module].")
- | _, (`Nm_val _ | `Nm_external _) , `Nm_na
- -> Js_module_as_class external_module_name
- | _, `Nm_payload _ , `Nm_na
- ->
- Location.raise_errorf ~loc
- "Incorrect FFI attribute found: (bs.new should not carry a payload here)"
- end
- | {module_as_val = Some x; _}
- ->
- Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.module].")
- | {call_name = (`Nm_val name | `Nm_external name | `Nm_payload name) ;
- splice;
- scopes ;
- external_module_name;
- val_name = `Nm_na ;
- module_as_val = None;
- val_send = `Nm_na ;
- val_send_pipe = None;
+(** Extension to Standard char module, avoid locale sensitivity *)
- set_index = false;
- get_index = false;
- new_name = `Nm_na;
- set_name = `Nm_na ;
- get_name = `Nm_na ;
- mk_obj = _ ;
- return_wrapper = _ ;
- } ->
- Js_call {splice; name; external_module_name; scopes }
- | {call_name = #bundle_source ; _ }
- ->
- Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.val]")
+val escaped : char -> string
- | {val_name = (`Nm_val name | `Nm_external name | `Nm_payload name);
- external_module_name;
+val valid_hex : char -> bool
- call_name = `Nm_na ;
- module_as_val = None;
- val_send = `Nm_na ;
- val_send_pipe = None;
- set_index = false;
- get_index = false;
- new_name = `Nm_na;
- set_name = `Nm_na ;
- get_name = `Nm_na;
- mk_obj = _;
- return_wrapper = _;
- splice = false ;
- scopes ;
- }
- ->
- Js_global { name; external_module_name; scopes}
- | {val_name = #bundle_source ; _ }
- ->
- Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.val]")
+val is_lower_case : char -> bool
+end = struct
+#1 "ext_char.ml"
+(* 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. *)
- | {splice ;
- scopes ;
- external_module_name = (Some _ as external_module_name);
- val_name = `Nm_na ;
- call_name = `Nm_na ;
- module_as_val = None;
- val_send = `Nm_na ;
- val_send_pipe = None;
- set_index = false;
- get_index = false;
- new_name = `Nm_na;
- set_name = `Nm_na ;
- get_name = `Nm_na ;
- mk_obj = _ ;
- return_wrapper= _ ;
- }
- ->
- let name = string_of_bundle_source prim_name_or_pval_prim in
- if arg_type_specs_length = 0 then
- Js_global { name; external_module_name; scopes}
- else Js_call {splice; name; external_module_name; scopes}
- | {val_send = (`Nm_val name | `Nm_external name | `Nm_payload name);
- splice;
- scopes;
- val_send_pipe = None;
- val_name = `Nm_na ;
- call_name = `Nm_na ;
- module_as_val = None;
- set_index = false;
- get_index = false;
- new_name = `Nm_na;
- set_name = `Nm_na ;
- get_name = `Nm_na ;
- external_module_name = None ;
- mk_obj = _ ;
- return_wrapper = _ ;
- } ->
- (* PR #2162 - since when we assemble arguments the first argument in
- [@@bs.send] is ignored
- *)
- begin match arg_type_specs with
- | [] ->
- Location.raise_errorf
- ~loc "Ill defined attribute [@@bs.send] (at least one argument)"
- | {arg_type = Arg_cst _ ; arg_label = _} :: _
- ->
- Location.raise_errorf
- ~loc "Ill defined attribute [@@bs.send] (first argument can not be const)"
- | _ :: _ ->
- Js_send {splice ; name; js_send_scopes = scopes ; pipe = false}
- end
- | {val_send = #bundle_source; _ }
- -> Location.raise_errorf ~loc "You used an FFI attribute that can't be used with [@@bs.send]"
- | {val_send_pipe = Some typ;
- (* splice = (false as splice); *)
- val_send = `Nm_na;
- val_name = `Nm_na ;
- call_name = `Nm_na ;
- module_as_val = None;
- set_index = false;
- get_index = false;
- new_name = `Nm_na;
- set_name = `Nm_na ;
- get_name = `Nm_na ;
- external_module_name = None ;
- mk_obj = _;
- return_wrapper = _;
- scopes;
- splice ;
- } ->
- (** can be one argument *)
- Js_send {splice ;
- name = string_of_bundle_source prim_name_or_pval_prim;
- js_send_scopes = scopes;
- pipe = true}
- | {val_send_pipe = Some _ ; _}
- -> Location.raise_errorf ~loc "conflict attributes found with [@@bs.send.pipe]"
- | {new_name = (`Nm_val name | `Nm_external name | `Nm_payload name);
- external_module_name;
+external string_unsafe_set : string -> int -> char -> unit
+ = "%string_unsafe_set"
- val_name = `Nm_na ;
- call_name = `Nm_na ;
- module_as_val = None;
- set_index = false;
- get_index = false;
- val_send = `Nm_na ;
- val_send_pipe = None;
- set_name = `Nm_na ;
- get_name = `Nm_na ;
- splice ;
- scopes;
- mk_obj = _ ;
- return_wrapper = _ ;
+external string_create: int -> string = "caml_create_string"
- }
- -> Js_new {name; external_module_name; splice; scopes}
- | {new_name = #bundle_source ; _ }
- ->
- Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.new]")
+external unsafe_chr: int -> char = "%identity"
+(** {!Char.escaped} is locale sensitive in 4.02.3, fixed in the trunk,
+ backport it here
+ *)
+let escaped = function
+ | '\'' -> "\\'"
+ | '\\' -> "\\\\"
+ | '\n' -> "\\n"
+ | '\t' -> "\\t"
+ | '\r' -> "\\r"
+ | '\b' -> "\\b"
+ | ' ' .. '~' as c ->
+ let s = string_create 1 in
+ string_unsafe_set s 0 c;
+ s
+ | c ->
+ let n = Char.code c in
+ let s = string_create 4 in
+ string_unsafe_set s 0 '\\';
+ string_unsafe_set s 1 (unsafe_chr (48 + n / 100));
+ string_unsafe_set s 2 (unsafe_chr (48 + (n / 10) mod 10));
+ string_unsafe_set s 3 (unsafe_chr (48 + n mod 10));
+ s
- | {set_name = (`Nm_val name | `Nm_external name | `Nm_payload name);
- val_name = `Nm_na ;
- call_name = `Nm_na ;
- module_as_val = None;
- set_index = false;
- get_index = false;
- val_send = `Nm_na ;
- val_send_pipe = None;
- new_name = `Nm_na ;
- get_name = `Nm_na ;
- external_module_name = None;
- splice = false;
- mk_obj = _ ;
- return_wrapper = _;
- scopes ;
- }
- ->
- if arg_type_specs_length = 2 then
- Js_set { js_set_scopes = scopes ; js_set_name = name}
- else Location.raise_errorf ~loc "Ill defined attribute [@@bs.set] (two args required)"
+let valid_hex x =
+ match x with
+ | '0' .. '9'
+ | 'a' .. 'f'
+ | 'A' .. 'F' -> true
+ | _ -> false
- | {set_name = #bundle_source; _}
- -> Location.raise_errorf ~loc "conflict attributes found with [@@bs.set]"
- | {get_name = (`Nm_val name | `Nm_external name | `Nm_payload name);
- val_name = `Nm_na ;
- call_name = `Nm_na ;
- module_as_val = None;
- set_index = false;
- get_index = false;
- val_send = `Nm_na ;
- val_send_pipe = None;
- new_name = `Nm_na ;
- set_name = `Nm_na ;
- external_module_name = None;
- splice = false ;
- mk_obj = _;
- return_wrapper = _;
- scopes
- }
- ->
- if arg_type_specs_length = 1 then
- Js_get { js_get_name = name; js_get_scopes = scopes }
- else
- Location.raise_errorf ~loc "Ill defined attribute [@@bs.get] (only one argument)"
- | {get_name = #bundle_source; _}
- -> Location.raise_errorf ~loc "Attribute found that conflicts with [@@bs.get]"
+let is_lower_case c =
+ (c >= 'a' && c <= 'z')
+ || (c >= '\224' && c <= '\246')
+ || (c >= '\248' && c <= '\254')
+end
+module Ast_utf8_string : sig
+#1 "ast_utf8_string.mli"
+(* 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. *)
- | {get_name = `Nm_na;
- val_name = `Nm_na ;
- call_name = `Nm_na ;
- module_as_val = None;
- set_index = false;
- get_index = false;
- val_send = `Nm_na ;
- val_send_pipe = None;
- new_name = `Nm_na ;
- set_name = `Nm_na ;
- external_module_name = None;
- splice = _ ;
- scopes = _;
- mk_obj = _;
- return_wrapper = _;
- }
- -> Location.raise_errorf ~loc "Could not infer which FFI category it belongs to, maybe you forgot [%@%@bs.val]? " in
- begin
- External_ffi_types.check_ffi ~loc ffi;
- (* result type can not be labeled *)
- (* currently we don't process attributes of
- return type, in the future we may *)
- let new_result_type = result_type in
- (* get_arg_type ~nolabel:true false result_type in *)
- let return_wrapper : External_ffi_types.return_wrapper =
- check_return_wrapper loc st.return_wrapper new_result_type
- in
- (
- Ext_list.fold_right (fun (label,ty,attrs,loc) acc ->
- Ast_helper.Typ.arrow ~loc ~attrs label ty acc
- ) new_arg_types_ty new_result_type
- ) ,
+type error
- prim_name,
- (Ffi_bs (arg_type_specs,return_wrapper , ffi)), left_attrs
- end
-let handle_attributes_as_string
- pval_loc
- pval_prim
- (typ : Ast_core_type.t) attrs v =
- let pval_type, prim_name, ffi, processed_attrs =
- handle_attributes pval_loc pval_prim typ attrs v in
- pval_type, [prim_name; External_ffi_types.to_string ffi], processed_attrs
+type exn += Error of int (* offset *) * error
+val pp_error : Format.formatter -> error -> unit
-let pval_prim_of_labels labels =
- let encoding =
- let arg_kinds =
- Ext_list.fold_right
- (fun {Asttypes.loc ; txt } arg_kinds
- ->
- let arg_label = External_arg_spec.label (Lam_methname.translate ~loc txt) None in
- {External_arg_spec.arg_type = Nothing ;
- arg_label } :: arg_kinds
- )
- labels [] in
- External_ffi_types.to_string
- (Ffi_obj_create arg_kinds) in
- [""; encoding]
+
+(* module Interp : sig *)
+(* val check_and_transform : int -> string -> int -> cxt -> unit *)
+(* val transform_test : string -> segments *)
+(* end *)
+val transform_test : string -> string
+val transform : Location.t -> string -> string
-end
-module Ast_util : sig
-#1 "ast_util.mli"
+
+end = struct
+#1 "ast_utf8_string.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -17648,116 +18679,183 @@ module Ast_util : sig
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-type args = (string * Parsetree.expression) list
-type loc = Location.t
-type label_exprs = (Longident.t Asttypes.loc * Parsetree.expression) list
-type 'a cxt = loc -> Bs_ast_mapper.mapper -> 'a
-
-(** In general three kinds of ast generation.
- - convert a curried to type to uncurried
- - convert a curried fun to uncurried fun
- - convert a uncuried application to normal
-*)
-type uncurry_expression_gen =
- (Parsetree.pattern ->
- Parsetree.expression ->
- Parsetree.expression_desc) cxt
-type uncurry_type_gen =
- (string -> (* label for error checking *)
- Parsetree.core_type ->
- Parsetree.core_type ->
- Parsetree.core_type) cxt
-(** TODO: the interface is not reusable, it depends on too much context *)
-(** syntax: {[f arg0 arg1 [@bs]]}*)
-val uncurry_fn_apply :
- (Parsetree.expression ->
- args ->
- Parsetree.expression_desc ) cxt
+type error =
+ | Invalid_code_point
+ | Unterminated_backslash
+ | Invalid_escape_code of char
+ | Invalid_hex_escape
+ | Invalid_unicode_escape
-(** syntax : {[f## arg0 arg1 ]}*)
-val method_apply :
- (Parsetree.expression ->
- string ->
- args ->
- Parsetree.expression_desc) cxt
+let pp_error fmt err =
+ Format.pp_print_string fmt @@ match err with
+ | Invalid_code_point -> "Invalid code point"
+ | Unterminated_backslash -> "\\ ended unexpectedly"
+ | Invalid_escape_code c -> "Invalid escape code: " ^ String.make 1 c
+ | Invalid_hex_escape ->
+ "Invalid \\x escape"
+ | Invalid_unicode_escape -> "Invalid \\u escape"
-(** syntax {[f#@ arg0 arg1 ]}*)
-val property_apply :
- (Parsetree.expression ->
- string ->
- args ->
- Parsetree.expression_desc) cxt
-(**
- [function] can only take one argument, that is the reason we did not adopt it
- syntax:
- {[ fun [@bs] pat pat1-> body ]}
- [to_uncurry_fn (fun pat -> (fun pat1 -> ... body))]
+type exn += Error of int (* offset *) * error
-*)
-val to_uncurry_fn : uncurry_expression_gen
-(** syntax:
- {[fun [@bs.this] obj pat pat1 -> body]}
-*)
-val to_method_callback : uncurry_expression_gen
+let error ~loc error =
+ raise (Error (loc, error))
-(** syntax :
- {[ int -> int -> int [@bs]]}
+(** Note the [loc] really should be the utf8-offset, it has nothing to do with our
+ escaping mechanism
*)
-val to_uncurry_type : uncurry_type_gen
-
+(* we can not just print new line in ES5
+ seems we don't need
+ escape "\b" "\f"
+ we need escape "\n" "\r" since
+ ocaml multiple-line allows [\n]
+ visual input while es5 string
+ does not*)
-(** syntax
- {[ method : int -> itn -> int ]}
-*)
-val to_method_type : uncurry_type_gen
+let rec check_and_transform (loc : int ) buf s byte_offset s_len =
+ if byte_offset = s_len then ()
+ else
+ let current_char = s.[byte_offset] in
+ match Ext_utf8.classify current_char with
+ | Single 92 (* '\\' *) ->
+ escape_code (loc + 1) buf s (byte_offset+1) s_len
+ | Single 34 ->
+ Buffer.add_string buf "\\\"";
+ check_and_transform (loc + 1) buf s (byte_offset + 1) s_len
+ | Single 39 ->
+ Buffer.add_string buf "\\'";
+ check_and_transform (loc + 1) buf s (byte_offset + 1) s_len
+ | Single 10 ->
+ Buffer.add_string buf "\\n";
+ check_and_transform (loc + 1) buf s (byte_offset + 1) s_len
+ | Single 13 ->
+ Buffer.add_string buf "\\r";
+ check_and_transform (loc + 1) buf s (byte_offset + 1) s_len
+ | Single _ ->
+ Buffer.add_char buf current_char;
+ check_and_transform (loc + 1) buf s (byte_offset + 1) s_len
-(** syntax:
- {[ 'obj -> int -> int [@bs.this] ]}
-*)
-val to_method_callback_type : uncurry_type_gen
+ | Invalid
+ | Cont _ -> error ~loc Invalid_code_point
+ | Leading (n,_) ->
+ let i' = Ext_utf8.next s ~remaining:n byte_offset in
+ if i' < 0 then
+ error ~loc Invalid_code_point
+ else
+ begin
+ for k = byte_offset to i' do
+ Buffer.add_char buf s.[k];
+ done;
+ check_and_transform (loc + 1 ) buf s (i' + 1) s_len
+ end
+(* we share the same escape sequence with js *)
+and escape_code loc buf s offset s_len =
+ if offset >= s_len then
+ error ~loc Unterminated_backslash
+ else
+ Buffer.add_char buf '\\';
+ let cur_char = s.[offset] in
+ match cur_char with
+ | '\\'
+ | 'b'
+ | 't'
+ | 'n'
+ | 'v'
+ | 'f'
+ | 'r'
+ | '0'
+ | '$'
+ ->
+ begin
+ Buffer.add_char buf cur_char ;
+ check_and_transform (loc + 1) buf s (offset + 1) s_len
+ end
+ | 'u' ->
+ begin
+ Buffer.add_char buf cur_char;
+ unicode (loc + 1) buf s (offset + 1) s_len
+ end
+ | 'x' -> begin
+ Buffer.add_char buf cur_char ;
+ two_hex (loc + 1) buf s (offset + 1) s_len
+ end
+ | _ -> error ~loc (Invalid_escape_code cur_char)
+and two_hex loc buf s offset s_len =
+ if offset + 1 >= s_len then
+ error ~loc Invalid_hex_escape;
+ (*Location.raise_errorf ~loc "\\x need at least two chars";*)
+ let a, b = s.[offset], s.[offset + 1] in
+ if Ext_char.valid_hex a && Ext_char.valid_hex b then
+ begin
+ Buffer.add_char buf a ;
+ Buffer.add_char buf b ;
+ check_and_transform (loc + 2) buf s (offset + 2) s_len
+ end
+ else
+ error ~loc Invalid_hex_escape
+(*Location.raise_errorf ~loc "%c%c is not a valid hex code" a b*)
+and unicode loc buf s offset s_len =
+ if offset + 3 >= s_len then
+ error ~loc Invalid_unicode_escape
+ (*Location.raise_errorf ~loc "\\u need at least four chars"*)
+ ;
+ let a0,a1,a2,a3 = s.[offset], s.[offset+1], s.[offset+2], s.[offset+3] in
+ if
+ Ext_char.valid_hex a0 &&
+ Ext_char.valid_hex a1 &&
+ Ext_char.valid_hex a2 &&
+ Ext_char.valid_hex a3 then
+ begin
+ Buffer.add_char buf a0;
+ Buffer.add_char buf a1;
+ Buffer.add_char buf a2;
+ Buffer.add_char buf a3;
+ check_and_transform (loc + 4) buf s (offset + 4) s_len
+ end
+ else
+ error ~loc Invalid_unicode_escape
+(*Location.raise_errorf ~loc "%c%c%c%c is not a valid unicode point"
+ a0 a1 a2 a3 *)
+(* http://www.2ality.com/2015/01/es6-strings.html
+ console.log('\uD83D\uDE80'); (* ES6*)
+ console.log('\u{1F680}');
+*)
-val record_as_js_object :
- (label_exprs ->
- Parsetree.expression_desc) cxt
-val js_property :
- loc ->
- Parsetree.expression -> string -> Parsetree.expression_desc
-val handle_debugger :
- loc -> Ast_payload.t -> Parsetree.expression_desc
-val handle_raw :
- ?check_js_regex: bool -> loc -> Ast_payload.t -> Parsetree.expression
-val handle_external :
- loc -> string -> Parsetree.expression
-
-val handle_raw_structure :
- loc -> Ast_payload.t -> Parsetree.structure_item
-val ocaml_obj_as_js_object :
- (Parsetree.pattern ->
- Parsetree.class_field list ->
- Parsetree.expression_desc) cxt
+let transform_test s =
+ let s_len = String.length s in
+ let buf = Buffer.create (s_len * 2) in
+ check_and_transform 0 buf s 0 s_len;
+ Buffer.contents buf
+
+let transform loc s =
+ let s_len = String.length s in
+ let buf = Buffer.create (s_len * 2) in
+ try
+ check_and_transform 0 buf s 0 s_len;
+ Buffer.contents buf
+ with
+ Error (offset, error)
+ -> Location.raise_errorf ~loc "Offset: %d, %a" offset pp_error error
- val convertBsErrorFunction :
-
- (Ast_helper.attrs -> Parsetree.case list -> Parsetree.expression) cxt
-end = struct
-#1 "ast_util.ml"
+end
+module Ast_utf8_string_interp : sig
+#1 "ast_utf8_string_interp.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -17782,787 +18880,500 @@ end = struct
* 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
-type 'a cxt = Ast_helper.loc -> Bs_ast_mapper.mapper -> 'a
-type loc = Location.t
-type args = (string * Parsetree.expression) list
-type label_exprs = (Longident.t Asttypes.loc * Parsetree.expression) list
-type uncurry_expression_gen =
- (Parsetree.pattern ->
- Parsetree.expression ->
- Parsetree.expression_desc) cxt
-type uncurry_type_gen =
- (string ->
- Parsetree.core_type ->
- Parsetree.core_type ->
- Parsetree.core_type) cxt
-
-let uncurry_type_id =
- Ast_literal.Lid.js_fn
-
-let method_id =
- Ast_literal.Lid.js_meth
-
-let method_call_back_id =
- Ast_literal.Lid.js_meth_callback
-
-let arity_lit = "Arity_"
-
-let mk_args loc n tys =
- Typ.variant ~loc
- [ Rtag (arity_lit ^ string_of_int n, [], (n = 0), tys)] Closed None
-
-let generic_lift txt loc args result =
- let xs =
- match args with
- | [ ] -> [mk_args loc 0 [] ; result ]
- | [ x ] -> [ mk_args loc 1 [x] ; result ]
- | _ ->
- [mk_args loc (List.length args ) [Typ.tuple ~loc args] ; result ]
- in
- Typ.constr ~loc {txt ; loc} xs
-
-let lift_curry_type loc =
- generic_lift uncurry_type_id loc
-
-let lift_method_type loc =
- generic_lift method_id loc
-
-let lift_js_method_callback loc
- =
- generic_lift method_call_back_id loc
-(** Note that currently there is no way to consume [Js.meth_callback]
- so it is fine to encode it with a freedom,
- but we need make it better for error message.
- - all are encoded as
- {[
- type fn = (`Args_n of _ , 'result ) Js.fn
- type method = (`Args_n of _, 'result) Js.method
- type method_callback = (`Args_n of _, 'result) Js.method_callback
- ]}
- For [method_callback], the arity is never zero, so both [method]
- and [fn] requires (unit -> 'a) to encode arity zero
-*)
-
-
-
-let arrow = Typ.arrow
-
-
-let js_property loc obj name =
- Parsetree.Pexp_send
- ((Exp.apply ~loc
- (Exp.ident ~loc
- {loc;
- txt = Ldot (Ast_literal.Lid.js_unsafe, Literals.unsafe_downgrade)})
- ["",obj]), name)
-
-(* TODO:
- have a final checking for property arities
- [#=],
-*)
-
-
-let generic_apply kind loc
- (self : Bs_ast_mapper.mapper)
- (obj : Parsetree.expression)
- (args : args ) cb =
- let obj = self.expr self obj in
- let args =
- Ext_list.map (fun (label,e) ->
- if label <> "" then
- Bs_syntaxerr.err loc Label_in_uncurried_bs_attribute;
- self.expr self e
- ) args in
- let len = List.length args in
- let arity, fn, args =
- match args with
- | [ {pexp_desc =
- Pexp_construct ({txt = Lident "()"}, None)}]
- ->
- 0, cb loc obj, []
- | _ ->
- len, cb loc obj, args in
- if arity < 10 then
- let txt =
- match kind with
- | `Fn | `PropertyFn ->
- Longident.Ldot (Ast_literal.Lid.js_unsafe,
- Literals.fn_run ^ string_of_int arity)
- | `Method ->
- Longident.Ldot(Ast_literal.Lid.js_unsafe,
- Literals.method_run ^ string_of_int arity
- ) in
- Parsetree.Pexp_apply (Exp.ident {txt ; loc}, ("",fn) :: Ext_list.map (fun x -> "",x) args)
- else
- let fn_type, args_type, result_type = Ast_comb.tuple_type_pair ~loc `Run arity in
- let string_arity = string_of_int arity in
- let pval_prim, pval_type =
- match kind with
- | `Fn | `PropertyFn ->
- ["#fn_run"; string_arity],
- arrow ~loc "" (lift_curry_type loc args_type result_type ) fn_type
- | `Method ->
- ["#method_run" ; string_arity],
- arrow ~loc "" (lift_method_type loc args_type result_type) fn_type
- in
- Ast_external_mk.local_external loc ~pval_prim ~pval_type
- (("", fn) :: Ext_list.map (fun x -> "",x) args )
-
-
-let uncurry_fn_apply loc self fn args =
- generic_apply `Fn loc self fn args (fun _ obj -> obj )
-
-let property_apply loc self obj name (args : args)
- = generic_apply `PropertyFn loc self obj args
- (fun loc obj -> Exp.mk ~loc (js_property loc obj name))
-
-let method_apply loc self obj name args =
- generic_apply `Method loc self obj args
- (fun loc obj -> Exp.mk ~loc (js_property loc obj name))
-
-let generic_to_uncurry_type kind loc (mapper : Bs_ast_mapper.mapper) label
- (first_arg : Parsetree.core_type)
- (typ : Parsetree.core_type) =
- if label <> "" then
- Bs_syntaxerr.err loc Label_in_uncurried_bs_attribute;
- let rec aux acc (typ : Parsetree.core_type) =
- (* in general,
- we should collect [typ] in [int -> typ] before transformation,
- however: when attributes [bs] and [bs.this] found in typ,
- we should stop
- *)
- match Ast_attributes.process_attributes_rev typ.ptyp_attributes with
- | `Nothing, _ ->
- begin match typ.ptyp_desc with
- | Ptyp_arrow (label, arg, body)
- ->
- if label <> "" then
- Bs_syntaxerr.err typ.ptyp_loc Label_in_uncurried_bs_attribute;
- aux (mapper.typ mapper arg :: acc) body
- | _ -> mapper.typ mapper typ, acc
- end
- | _, _ -> mapper.typ mapper typ, acc
- in
- let first_arg = mapper.typ mapper first_arg in
- let result, rev_extra_args = aux [first_arg] typ in
- let args = List.rev rev_extra_args in
- let filter_args args =
- match args with
- | [{Parsetree.ptyp_desc =
- (Ptyp_constr ({txt = Lident "unit"}, [])
- )}]
- -> []
- | _ -> args in
- match kind with
- | `Fn ->
- let args = filter_args args in
- lift_curry_type loc args result
- | `Method ->
- let args = filter_args args in
- lift_method_type loc args result
+type kind =
+ | String
+ | Var
+type error = private
+ | Invalid_code_point
+ | Unterminated_backslash
+ | Invalid_escape_code of char
+ | Invalid_hex_escape
+ | Invalid_unicode_escape
+ | Unterminated_variable
+ | Unmatched_paren
+ | Invalid_syntax_of_var of string
- | `Method_callback
- -> lift_js_method_callback loc args result
+(** Note the position is about code point *)
+type pos = { lnum : int ; offset : int ; byte_bol : int }
+type segment = {
+ start : pos;
+ finish : pos ;
+ kind : kind;
+ content : string ;
+}
-let to_uncurry_type =
- generic_to_uncurry_type `Fn
-let to_method_type =
- generic_to_uncurry_type `Method
-let to_method_callback_type =
- generic_to_uncurry_type `Method_callback
+type segments = segment list
-let generic_to_uncurry_exp kind loc (self : Bs_ast_mapper.mapper) pat body
- =
- let rec aux acc (body : Parsetree.expression) =
- match Ast_attributes.process_attributes_rev body.pexp_attributes with
- | `Nothing, _ ->
- begin match body.pexp_desc with
- | Pexp_fun (label,_, arg, body)
- ->
- if label <> "" then
- Bs_syntaxerr.err loc Label_in_uncurried_bs_attribute;
- aux (self.pat self arg :: acc) body
- | _ -> self.expr self body, acc
- end
- | _, _ -> self.expr self body, acc
- in
- let first_arg = self.pat self pat in
- let () =
- match kind with
- | `Method_callback ->
- if not @@ Ast_pat.is_single_variable_pattern_conservative first_arg then
- Bs_syntaxerr.err first_arg.ppat_loc Bs_this_simple_pattern
- | _ -> ()
- in
+type cxt = {
+ mutable segment_start : pos ;
+ buf : Buffer.t ;
+ s_len : int ;
+ mutable segments : segments;
+ mutable pos_bol : int; (* record the abs position of current beginning line *)
+ mutable byte_bol : int ;
+ mutable pos_lnum : int ; (* record the line number *)
+}
- let result, rev_extra_args = aux [first_arg] body in
- let body =
- List.fold_left (fun e p -> Ast_comb.fun_no_label ~loc p e )
- result rev_extra_args in
- let len = List.length rev_extra_args in
- let arity =
- match kind with
- | `Fn ->
- begin match rev_extra_args with
- | [ p]
- ->
- Ast_pat.is_unit_cont ~yes:0 ~no:len p
+type exn += Error of pos * pos * error
- | _ -> len
- end
- | `Method_callback -> len in
- if arity < 10 then
- let txt =
- match kind with
- | `Fn ->
- Longident.Ldot ( Ast_literal.Lid.js_unsafe, Literals.fn_mk ^ string_of_int arity)
- | `Method_callback ->
- Longident.Ldot (Ast_literal.Lid.js_unsafe, Literals.fn_method ^ string_of_int arity) in
- Parsetree.Pexp_apply (Exp.ident {txt;loc} , ["",body])
+val empty_segment : segment -> bool
- else
- let pval_prim =
- [ (match kind with
- | `Fn -> "#fn_mk"
- | `Method_callback -> "#fn_method");
- string_of_int arity] in
- let fn_type , args_type, result_type = Ast_comb.tuple_type_pair ~loc `Make arity in
- let pval_type = arrow ~loc "" fn_type (
- match kind with
- | `Fn ->
- lift_curry_type loc args_type result_type
- | `Method_callback ->
- lift_js_method_callback loc args_type result_type
- ) in
- Ast_external_mk.local_extern_cont loc ~pval_prim ~pval_type
- (fun prim -> Exp.apply ~loc prim ["", body])
+val transform_test : string -> segment list
+val transform_interp : Location.t -> string -> Parsetree.expression
-let to_uncurry_fn =
- generic_to_uncurry_exp `Fn
-let to_method_callback =
- generic_to_uncurry_exp `Method_callback
+end = struct
+#1 "ast_utf8_string_interp.ml"
+(* 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 error =
+ | Invalid_code_point
+ | Unterminated_backslash
+ | Invalid_escape_code of char
+ | Invalid_hex_escape
+ | Invalid_unicode_escape
+ | Unterminated_variable
+ | Unmatched_paren
+ | Invalid_syntax_of_var of string
+type kind =
+ | String
+ | Var
-let handle_debugger loc payload =
- if Ast_payload.as_empty_structure payload then
- Parsetree.Pexp_apply
- (Exp.ident {txt = Ldot(Ast_literal.Lid.js_unsafe, Literals.debugger ); loc},
- ["", Ast_literal.val_unit ~loc ()])
- else Location.raise_errorf ~loc "bs.raw can only be applied to a string"
+(** Note the position is about code point *)
+type pos = {
+ lnum : int ;
+ offset : int ;
+ byte_bol : int (* Note it actually needs to be in sync with OCaml's lexing semantics *)
+}
-let handle_raw ?(check_js_regex = false) loc payload =
- begin match Ast_payload.as_string_exp ~check_js_regex payload with
- | Not_String_Lteral ->
- Location.raise_errorf ~loc
- "bs.raw can only be applied to a string"
- | Ast_payload.JS_Regex_Check_Failed ->
- Location.raise_errorf ~loc "this is an invalid js regex"
- | Correct exp ->
- let pexp_desc =
- Parsetree.Pexp_apply (
- Exp.ident {loc;
- txt =
- Ldot (Ast_literal.Lid.js_unsafe,
- Literals.raw_expr)},
- ["",exp]
- )
- in
- { exp with pexp_desc }
- end
-let handle_external loc x =
- let raw_exp : Ast_exp.t =
- Ast_helper.Exp.apply
- (Exp.ident ~loc
- {loc; txt = Ldot (Ast_literal.Lid.js_unsafe,
- Literals.raw_expr)})
- ~loc
- [Ext_string.empty,
- Exp.constant ~loc (Const_string (x,Some Ext_string.empty))] in
- let empty =
- Exp.ident ~loc
- {txt = Ldot (Ldot(Lident"Js", "Undefined"), "empty");loc}
- in
- let undefined_typeof =
- Exp.ident {loc ; txt = Ldot(Lident "Js","undefinedToOption")} in
- let typeof =
- Exp.ident {loc ; txt = Ldot(Lident "Js","typeof")} in
+type segment = {
+ start : pos;
+ finish : pos ;
+ kind : kind;
+ content : string ;
+}
- Exp.apply ~loc undefined_typeof [
- Ext_string.empty,
- Exp.ifthenelse ~loc
- (Exp.apply ~loc
- (Exp.ident ~loc {loc ; txt = Ldot (Lident "Pervasives", "=")} )
- [
- Ext_string.empty,
- (Exp.apply ~loc typeof [Ext_string.empty,raw_exp]);
- Ext_string.empty,
- Exp.constant ~loc (Const_string ("undefined",None))
- ])
- (empty)
- (Some raw_exp)
- ]
+type segments = segment list
-let handle_raw_structure loc payload =
- begin match Ast_payload.as_string_exp payload with
- | Correct exp
- ->
- let pexp_desc =
- Parsetree.Pexp_apply(
- Exp.ident {txt = Ldot (Ast_literal.Lid.js_unsafe, Literals.raw_stmt); loc},
- ["",exp]) in
- Ast_helper.Str.eval
- { exp with pexp_desc }
+type cxt = {
+ mutable segment_start : pos ;
+ buf : Buffer.t ;
+ s_len : int ;
+ mutable segments : segments;
+ mutable pos_bol : int; (* record the abs position of current beginning line *)
+ mutable byte_bol : int ;
+ mutable pos_lnum : int ; (* record the line number *)
+}
- | Not_String_Lteral
- ->
- Location.raise_errorf ~loc "bs.raw can only be applied to a string"
- | JS_Regex_Check_Failed
- ->
- Location.raise_errorf ~loc "this is an invalid js regex"
- end
+type exn += Error of pos * pos * error
-let ocaml_obj_as_js_object
- loc (mapper : Bs_ast_mapper.mapper)
- (self_pat : Parsetree.pattern)
- (clfs : Parsetree.class_field list) =
- let self_type_lit = "self_type" in
+let pp_error fmt err =
+ Format.pp_print_string fmt @@ match err with
+ | Invalid_code_point -> "Invalid code point"
+ | Unterminated_backslash -> "\\ ended unexpectedly"
+ | Invalid_escape_code c -> "Invalid escape code: " ^ String.make 1 c
+ | Invalid_hex_escape ->
+ "Invalid \\x escape"
+ | Invalid_unicode_escape -> "Invalid \\u escape"
+ | Unterminated_variable -> "$ unterminated"
+ | Unmatched_paren -> "Unmatched paren"
+ | Invalid_syntax_of_var s -> "`" ^s ^ "' is not a valid syntax of interpolated identifer"
+let valid_lead_identifier_char x =
+ match x with
+ | 'a'..'z' | '_' -> true
+ | _ -> false
- (** Attention: we should avoid type variable conflict for each method
- Since the method name is unique, there would be no conflict
- OCaml does not allow duplicate instance variable and duplicate methods,
- but it does allow duplicates between instance variable and method name,
- we should enforce such rules
- {[
- object
- val x = 3
- method x = 3
- end [@bs]
- ]} should not compile with a meaningful error message
- *)
+let valid_identifier_char x =
+ match x with
+ | 'a'..'z'
+ | 'A'..'Z'
+ | '0'..'9'
+ | '_' | '\''-> true
+ | _ -> false
+(** Invariant: [valid_lead_identifier] has to be [valid_identifier] *)
- let generate_val_method_pair
- loc (mapper : Bs_ast_mapper.mapper)
- val_name is_mutable =
+let valid_identifier s =
+ let s_len = String.length s in
+ if s_len = 0 then false
+ else
+ valid_lead_identifier_char s.[0] &&
+ Ext_string.for_all_from s 1 valid_identifier_char
+
+
+let is_space x =
+ match x with
+ | ' ' | '\n' | '\t' -> true
+ | _ -> false
- let result = Typ.var ~loc val_name in
- result ,
- ((val_name , [], result ) ::
- (if is_mutable then
- [val_name ^ Literals.setter_suffix,[],
- to_method_type loc mapper "" result (Ast_literal.type_unit ~loc ()) ]
- else
- []) )
- in
- (* Note mapper is only for API compatible
- * TODO: we should check label name to avoid conflict
- *)
- let self_type loc = Typ.var ~loc self_type_lit in
- let generate_arg_type loc (mapper : Bs_ast_mapper.mapper)
- method_name arity : Ast_core_type.t =
- let result = Typ.var ~loc method_name in
- if arity = 0 then
- to_method_type loc mapper "" (Ast_literal.type_unit ~loc ()) result
- else
- let tyvars =
- Ext_list.init arity (fun i -> Typ.var ~loc (method_name ^ string_of_int i))
- in
- begin match tyvars with
- | x :: rest ->
- let method_rest =
- Ext_list.fold_right (fun v acc -> Typ.arrow ~loc "" v acc)
- rest result in
- to_method_type loc mapper "" x method_rest
- | _ -> assert false
- end in
+(**
+ FIXME: multiple line offset
+ if there is no line offset. Note {|{j||} border will never trigger a new line
+*)
+let update_position border
+ ({lnum ; offset;byte_bol } : pos)
+ (pos : Lexing.position)=
+ if lnum = 0 then
+ {pos with pos_cnum = pos.pos_cnum + border + offset }
+ (** When no newline, the column number is [border + offset] *)
+ else
+ {
+ pos with
+ pos_lnum = pos.pos_lnum + lnum ;
+ pos_bol = pos.pos_cnum + border + byte_bol;
+ pos_cnum = pos.pos_cnum + border + byte_bol + offset;
+ (** when newline, the column number is [offset] *)
+ }
+let update border
+ (start : pos)
+ (finish : pos) (loc : Location.t) : Location.t =
+ let start_pos = loc.loc_start in
+ { loc with
+ loc_start =
+ update_position border start start_pos;
+ loc_end =
+ update_position border finish start_pos
+ }
- let generate_method_type
- loc
- (mapper : Bs_ast_mapper.mapper)
- ?alias_type method_name arity =
- let result = Typ.var ~loc method_name in
- let self_type =
- let v = self_type loc in
- match alias_type with
- | None -> v
- | Some ty -> Typ.alias ~loc ty self_type_lit
- in
- if arity = 0 then
- to_method_callback_type loc mapper "" self_type result
- else
- let tyvars =
- Ext_list.init arity (fun i -> Typ.var ~loc (method_name ^ string_of_int i))
- in
- begin match tyvars with
- | x :: rest ->
- let method_rest =
- Ext_list.fold_right (fun v acc -> Typ.arrow ~loc "" v acc)
- rest result in
- (to_method_callback_type loc mapper "" self_type
- (Typ.arrow ~loc "" x method_rest))
- | _ -> assert false
- end in
+(** Note [Var] kind can not be mpty *)
+let empty_segment {content } =
+ Ext_string.is_empty content
- (** we need calculate the real object type
- and exposed object type, in some cases there are equivalent
- for public object type its [@bs.meth] it does not depend on itself
- while for label argument it is [@bs.this] which depends internal object
- *)
- let internal_label_attr_types, public_label_attr_types =
- Ext_list.fold_right
- (fun ({pcf_loc = loc} as x : Parsetree.class_field)
- (label_attr_types, public_label_attr_types) ->
- match x.pcf_desc with
- | Pcf_method (
- label,
- public_flag,
- Cfk_concrete
- (Fresh, e))
- ->
- begin match e.pexp_desc with
- | Pexp_poly
- (({pexp_desc = Pexp_fun ("", None, pat, e)} ),
- None) ->
- let arity = Ast_pat.arity_of_fun pat e in
- let method_type =
- generate_arg_type x.pcf_loc mapper label.txt arity in
- ((label.Asttypes.txt, [], method_type) :: label_attr_types),
- (if public_flag = Public then
- (label.Asttypes.txt, [], method_type) :: public_label_attr_types
- else
- public_label_attr_types)
+let update_newline ~byte_bol loc cxt =
+ cxt.pos_lnum <- cxt.pos_lnum + 1 ;
+ cxt.pos_bol <- loc;
+ cxt.byte_bol <- byte_bol
- | Pexp_poly( _, Some _)
- ->
- Location.raise_errorf ~loc "polymorphic type annotation not supported yet"
- | Pexp_poly (_, None) ->
- Location.raise_errorf ~loc
- "Unsupported syntax, expect syntax like `method x () = x ` "
- | _ ->
- Location.raise_errorf ~loc "Unsupported syntax in js object"
- end
- | Pcf_val (label, mutable_flag, Cfk_concrete(Fresh, val_exp)) ->
- let label_type, label_attr =
- generate_val_method_pair x.pcf_loc mapper label.txt
- (mutable_flag = Mutable )
- in
- (Ext_list.append label_attr label_attr_types, public_label_attr_types)
- | Pcf_val (label, mutable_flag, Cfk_concrete(Override, val_exp)) ->
- Location.raise_errorf ~loc "override flag not support currently"
- | Pcf_val (label, mutable_flag, Cfk_virtual _) ->
- Location.raise_errorf ~loc "virtual flag not support currently"
+let pos_error cxt ~loc error =
+ raise (Error
+ (cxt.segment_start,
+ { lnum = cxt.pos_lnum ; offset = loc - cxt.pos_bol ; byte_bol = cxt.byte_bol}, error))
- | Pcf_method (_, _, Cfk_concrete(Override, _) ) ->
- Location.raise_errorf ~loc "override flag not supported"
+let add_var_segment cxt loc =
+ let content = Buffer.contents cxt.buf in
+ Buffer.clear cxt.buf ;
+ let next_loc = {
+ lnum = cxt.pos_lnum ; offset = loc - cxt.pos_bol ;
+ byte_bol = cxt.byte_bol } in
+ if valid_identifier content then
+ begin
+ cxt.segments <-
+ { start = cxt.segment_start;
+ finish = next_loc ;
+ kind = Var;
+ content} :: cxt.segments ;
+ cxt.segment_start <- next_loc
+ end
+ else pos_error cxt ~loc (Invalid_syntax_of_var content)
- | Pcf_method (_, _, Cfk_virtual _ )
- ->
- Location.raise_errorf ~loc "virtural method not supported"
+let add_str_segment cxt loc =
+ let content = Buffer.contents cxt.buf in
+ Buffer.clear cxt.buf ;
+ let next_loc = {
+ lnum = cxt.pos_lnum ; offset = loc - cxt.pos_bol ;
+ byte_bol = cxt.byte_bol } in
+ cxt.segments <-
+ { start = cxt.segment_start;
+ finish = next_loc ;
+ kind = String;
+ content} :: cxt.segments ;
+ cxt.segment_start <- next_loc
- | Pcf_inherit _
- | Pcf_initializer _
- | Pcf_attribute _
- | Pcf_extension _
- | Pcf_constraint _ ->
- Location.raise_errorf ~loc "Only method support currently"
- ) clfs ([], []) in
- let internal_obj_type = Ast_core_type.make_obj ~loc internal_label_attr_types in
- let public_obj_type = Ast_core_type.make_obj ~loc public_label_attr_types in
- let (labels, label_types, exprs, _) =
- Ext_list.fold_right
- (fun (x : Parsetree.class_field)
- (labels,
- label_types,
- exprs, aliased ) ->
- match x.pcf_desc with
- | Pcf_method (
- label,
- _public_flag,
- Cfk_concrete
- (Fresh, e))
- ->
- begin match e.pexp_desc with
- | Pexp_poly
- (({pexp_desc = Pexp_fun ("", None, pat, e)} as f),
- None) ->
- let arity = Ast_pat.arity_of_fun pat e in
- let alias_type =
- if aliased then None
- else Some internal_obj_type in
- let label_type =
- generate_method_type ?alias_type
- x.pcf_loc mapper label.txt arity in
- (label::labels,
- label_type::label_types,
- {f with
- pexp_desc =
- let f = Ast_pat.is_unit_cont pat ~yes:e ~no:f in
- to_method_callback loc mapper self_pat f
- } :: exprs,
- true
- )
- | Pexp_poly( _, Some _)
- ->
- Location.raise_errorf ~loc
- "polymorphic type annotation not supported yet"
- | Pexp_poly (_, None) ->
- Location.raise_errorf
- ~loc "Unsupported syntax, expect syntax like `method x () = x ` "
- | _ ->
- Location.raise_errorf ~loc "Unsupported syntax in js object"
- end
- | Pcf_val (label, mutable_flag, Cfk_concrete(Fresh, val_exp)) ->
- let label_type, label_attr =
- generate_val_method_pair x.pcf_loc mapper label.txt
- (mutable_flag = Mutable )
- in
- (label::labels,
- label_type :: label_types,
- (mapper.expr mapper val_exp :: exprs),
- aliased
- )
+
- | Pcf_val (label, mutable_flag, Cfk_concrete(Override, val_exp)) ->
- Location.raise_errorf ~loc "override flag not support currently"
- | Pcf_val (label, mutable_flag, Cfk_virtual _) ->
- Location.raise_errorf ~loc "virtual flag not support currently"
- | Pcf_method (_, _, Cfk_concrete(Override, _) ) ->
- Location.raise_errorf ~loc "override flag not supported"
+let rec check_and_transform (loc : int ) s byte_offset ({s_len; buf} as cxt : cxt) =
+ if byte_offset = s_len then
+ add_str_segment cxt loc
+ else
+ let current_char = s.[byte_offset] in
+ match Ext_utf8.classify current_char with
+ | Single 92 (* '\\' *) ->
+ escape_code (loc + 1) s (byte_offset+1) cxt
+ | Single 34 ->
+ Buffer.add_string buf "\\\"";
+ check_and_transform (loc + 1) s (byte_offset + 1) cxt
+ | Single 39 ->
+ Buffer.add_string buf "\\'";
+ check_and_transform (loc + 1) s (byte_offset + 1) cxt
+ | Single 10 ->
+
+ Buffer.add_string buf "\\n";
+ let loc = loc + 1 in
+ let byte_offset = byte_offset + 1 in
+ update_newline ~byte_bol:byte_offset loc cxt ; (* Note variable could not have new-line *)
+ check_and_transform loc s byte_offset cxt
+ | Single 13 ->
+ Buffer.add_string buf "\\r";
+ check_and_transform (loc + 1) s (byte_offset + 1) cxt
+ | Single 36 -> (* $ *)
+ add_str_segment cxt loc ;
+ let offset = byte_offset + 1 in
+ if offset >= s_len then
+ pos_error ~loc cxt Unterminated_variable
+ else
+ let cur_char = s.[offset] in
+ if cur_char = '(' then
+ expect_var_paren (loc + 2) s (offset + 1) cxt
+ else
+ expect_simple_var (loc + 1) s offset cxt
+ | Single _ ->
+ Buffer.add_char buf current_char;
+ check_and_transform (loc + 1) s (byte_offset + 1) cxt
- | Pcf_method (_, _, Cfk_virtual _ )
- ->
- Location.raise_errorf ~loc "virtural method not supported"
+ | Invalid
+ | Cont _ -> pos_error ~loc cxt Invalid_code_point
+ | Leading (n,_) ->
+ let i' = Ext_utf8.next s ~remaining:n byte_offset in
+ if i' < 0 then
+ pos_error cxt ~loc Invalid_code_point
+ else
+ begin
+ for k = byte_offset to i' do
+ Buffer.add_char buf s.[k];
+ done;
+ check_and_transform (loc + 1 ) s (i' + 1) cxt
+ end
+(**Lets keep identifier simple, so that we could generating a function easier in the future
+ for example
+ let f = [%fn{| $x + $y = $x_add_y |}]
+*)
+and expect_simple_var loc s offset ({buf; s_len} as cxt) =
+ let v = ref offset in
+ (* prerr_endline @@ Ext_pervasives.dump (s, has_paren, (is_space s.[!v]), !v); *)
+ if not (offset < s_len && valid_lead_identifier_char s.[offset]) then
+ pos_error cxt ~loc (Invalid_syntax_of_var Ext_string.empty)
+ else
+ begin
+ while !v < s_len && valid_identifier_char s.[!v] do (* TODO*)
+ let cur_char = s.[!v] in
+ Buffer.add_char buf cur_char;
+ incr v ;
+ done;
+ let added_length = !v - offset in
+ let loc = added_length + loc in
+ add_var_segment cxt loc ;
+ check_and_transform loc s (added_length + offset) cxt
+ end
+and expect_var_paren loc s offset ({buf; s_len} as cxt) =
+ let v = ref offset in
+ (* prerr_endline @@ Ext_pervasives.dump (s, has_paren, (is_space s.[!v]), !v); *)
+ while !v < s_len && s.[!v] <> ')' do
+ let cur_char = s.[!v] in
+ Buffer.add_char buf cur_char;
+ incr v ;
+ done;
+ let added_length = !v - offset in
+ let loc = added_length + 1 + loc in
+ if !v < s_len && s.[!v] = ')' then
+ begin
+ add_var_segment cxt loc ;
+ check_and_transform loc s (added_length + 1 + offset) cxt
+ end
+ else
+ pos_error cxt ~loc Unmatched_paren
- | Pcf_inherit _
- | Pcf_initializer _
- | Pcf_attribute _
- | Pcf_extension _
- | Pcf_constraint _ ->
- Location.raise_errorf ~loc "Only method support currently"
- ) clfs ([], [], [], false) in
- let pval_type =
- Ext_list.fold_right2
- (fun label label_type acc ->
- Typ.arrow
- ~loc:label.Asttypes.loc
- label.Asttypes.txt
- label_type acc
- ) labels label_types public_obj_type in
- Ast_external_mk.local_extern_cont
- loc
- ~pval_prim:(External_process.pval_prim_of_labels labels)
- (fun e ->
- Exp.apply ~loc e
- (Ext_list.map2 (fun l expr -> l.Asttypes.txt, expr) labels exprs) )
- ~pval_type
-let record_as_js_object
- loc
- (self : Bs_ast_mapper.mapper)
- (label_exprs : label_exprs)
- : Parsetree.expression_desc =
- let labels,args, arity =
- Ext_list.fold_right (fun ({Location.txt ; loc}, e) (labels,args,i) ->
- match txt with
- | Longident.Lident x ->
- ({Asttypes.loc = loc ; txt = x} :: labels, (x, self.expr self e) :: args, i + 1)
- | Ldot _ | Lapply _ ->
- Location.raise_errorf ~loc "invalid js label ") label_exprs ([],[],0) in
- Ast_external_mk.local_external loc
- ~pval_prim:(External_process.pval_prim_of_labels labels)
- ~pval_type:(Ast_core_type.from_labels ~loc arity labels)
- args
+(* we share the same escape sequence with js *)
+and escape_code loc s offset ({ buf; s_len} as cxt) =
+ if offset >= s_len then
+ pos_error cxt ~loc Unterminated_backslash
+ else
+ Buffer.add_char buf '\\';
+ let cur_char = s.[offset] in
+ match cur_char with
+ | '\\'
+ | 'b'
+ | 't'
+ | 'n'
+ | 'v'
+ | 'f'
+ | 'r'
+ | '0'
+ | '$'
+ ->
+ begin
+ Buffer.add_char buf cur_char ;
+ check_and_transform (loc + 1) s (offset + 1) cxt
+ end
+ | 'u' ->
+ begin
+ Buffer.add_char buf cur_char;
+ unicode (loc + 1) s (offset + 1) cxt
+ end
+ | 'x' -> begin
+ Buffer.add_char buf cur_char ;
+ two_hex (loc + 1) s (offset + 1) cxt
+ end
+ | _ -> pos_error cxt ~loc (Invalid_escape_code cur_char)
+and two_hex loc s offset ({buf ; s_len} as cxt) =
+ if offset + 1 >= s_len then
+ pos_error cxt ~loc Invalid_hex_escape;
+ let a, b = s.[offset], s.[offset + 1] in
+ if Ext_char.valid_hex a && Ext_char.valid_hex b then
+ begin
+ Buffer.add_char buf a ;
+ Buffer.add_char buf b ;
+ check_and_transform (loc + 2) s (offset + 2) cxt
+ end
+ else
+ pos_error cxt ~loc Invalid_hex_escape
+and unicode loc s offset ({buf ; s_len} as cxt) =
+ if offset + 3 >= s_len then
+ pos_error cxt ~loc Invalid_unicode_escape
+ ;
+ let a0,a1,a2,a3 = s.[offset], s.[offset+1], s.[offset+2], s.[offset+3] in
+ if
+ Ext_char.valid_hex a0 &&
+ Ext_char.valid_hex a1 &&
+ Ext_char.valid_hex a2 &&
+ Ext_char.valid_hex a3 then
+ begin
+ Buffer.add_char buf a0;
+ Buffer.add_char buf a1;
+ Buffer.add_char buf a2;
+ Buffer.add_char buf a3;
+ check_and_transform (loc + 4) s (offset + 4) cxt
+ end
+ else
+ pos_error cxt ~loc Invalid_unicode_escape
+let transform_test s =
+ let s_len = String.length s in
+ let buf = Buffer.create (s_len * 2) in
+ let cxt =
+ { segment_start = {lnum = 0; offset = 0; byte_bol = 0};
+ buf ;
+ s_len;
+ segments = [];
+ pos_lnum = 0;
+ byte_bol = 0;
+ pos_bol = 0;
-let isCamlExceptionOrOpenVariant = Longident.parse "Caml_exceptions.isCamlExceptionOrOpenVariant"
-let obj_magic = Longident.parse "Obj.magic"
+ } in
+ check_and_transform 0 s 0 cxt;
+ List.rev cxt.segments
-let rec checkCases (cases : Parsetree.case list) =
- List.iter check_case cases
-and check_case case =
- check_pat case.pc_lhs
-and check_pat (pat : Parsetree.pattern) =
- match pat.ppat_desc with
- | Ppat_construct _ -> ()
- | Ppat_or (l,r) ->
- check_pat l; check_pat r
- | _ -> Location.raise_errorf ~loc:pat.ppat_loc "Unsupported pattern in `bs.open`"
-let convertBsErrorFunction loc (self : Bs_ast_mapper.mapper) attrs (cases : Parsetree.case list ) =
- let txt = "match" in
- let txt_expr = Exp.ident ~loc {txt = Lident txt; loc} in
- let none = Exp.constraint_ ~loc
- (Exp.construct ~loc {txt = Lident "None" ; loc} None)
- (Ast_core_type.lift_option_type (Typ.any ~loc ())) in
- let () = checkCases cases in
- let cases = self.cases self cases in
- Exp.fun_ ~attrs ~loc "" None ( Pat.var ~loc {txt; loc })
- (Exp.ifthenelse
- ~loc
- (Exp.apply ~loc (Exp.ident ~loc {txt = isCamlExceptionOrOpenVariant ; loc}) ["", txt_expr ])
- (Exp.match_ ~loc
- (Exp.constraint_ ~loc
- (Exp.apply ~loc (Exp.ident ~loc {txt = obj_magic; loc}) ["", txt_expr])
- (Ast_literal.type_exn ~loc ())
- )
- (Ext_list.map_append (fun (x :Parsetree.case ) ->
- let pc_rhs = x.pc_rhs in
- let loc = pc_rhs.pexp_loc in
- {
- x with pc_rhs =
- Exp.constraint_ ~loc
- (Exp.construct ~loc {txt = Lident "Some";loc} (Some pc_rhs))
- (Ast_core_type.lift_option_type (Typ.any ~loc ()) )
- }
+(** TODO: test empty var $() $ failure,
+ Allow identifers x.A.y *)
- ) cases
- [
- Exp.case (Pat.any ~loc ()) none
- ])
- )
- (Some none))
-
-
+open Ast_helper
-end
-module Ext_ref : sig
-#1 "ext_ref.mli"
-(* 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. *)
+(** Longident.parse "Pervasives.^" *)
+let concat_ident : Longident.t =
+ Ldot (Lident "Pervasives", "^")
+ (* JS string concatMany *)
+ (* Ldot (Ldot (Lident "Js", "String"), "concat") *)
-(** [non_exn_protect ref value f] assusme [f()]
- would not raise
-*)
+(* Longident.parse "Js.String.make" *)
+let to_string_ident : Longident.t =
+ Ldot (Ldot (Lident "Js", "String"), "make")
-val non_exn_protect : 'a ref -> 'a -> (unit -> 'b) -> 'b
-val protect : 'a ref -> 'a -> (unit -> 'b) -> 'b
-val protect2 : 'a ref -> 'b ref -> 'a -> 'b -> (unit -> 'c) -> 'c
-(** [non_exn_protect2 refa refb va vb f ]
- assume [f ()] would not raise
-*)
-val non_exn_protect2 : 'a ref -> 'b ref -> 'a -> 'b -> (unit -> 'c) -> 'c
+let escaped = Some Literals.escaped_j_delimiter
-val protect_list : ('a ref * 'a) list -> (unit -> 'b) -> 'b
+let concat_exp
+ (a : Parsetree.expression)
+ (b : Parsetree.expression) : Parsetree.expression =
+ let loc = Bs_loc.merge a.pexp_loc b.pexp_loc in
+ Exp.apply ~loc
+ (Exp.ident { txt =concat_ident; loc})
+ ["",a ;
+ "",b]
-end = struct
-#1 "ext_ref.ml"
-(* 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 border = String.length "{j|"
-let non_exn_protect r v body =
- let old = !r in
- r := v;
- let res = body() in
- r := old;
- res
+let aux loc (segment : segment) =
+ match segment with
+ | {start ; finish; kind ; content}
+ ->
+ let loc = update border start finish loc in
+ begin match kind with
+ | String ->
+ Exp.constant
+ ~loc
+ (Const_string (content, escaped))
+ | Var ->
+ Exp.apply ~loc
+ (Exp.ident ~loc {loc ; txt = to_string_ident })
+ [
+ "",
+ Exp.ident ~loc {loc ; txt = Lident content}
+ ]
+ end
-let protect r v body =
- let old = !r in
- try
- r := v;
- let res = body() in
- r := old;
- res
- with x ->
- r := old;
- raise x
-let non_exn_protect2 r1 r2 v1 v2 body =
- let old1 = !r1 in
- let old2 = !r2 in
- r1 := v1;
- r2 := v2;
- let res = body() in
- r1 := old1;
- r2 := old2;
- res
+let transform_interp loc s =
+ let s_len = String.length s in
+ let buf = Buffer.create (s_len * 2 ) in
+ try
+ let cxt : cxt =
+ { segment_start = {lnum = 0; offset = 0; byte_bol = 0};
+ buf ;
+ s_len;
+ segments = [];
+ pos_lnum = 0;
+ byte_bol = 0;
+ pos_bol = 0;
-let protect2 r1 r2 v1 v2 body =
- let old1 = !r1 in
- let old2 = !r2 in
- try
- r1 := v1;
- r2 := v2;
- let res = body() in
- r1 := old1;
- r2 := old2;
- res
- with x ->
- r1 := old1;
- r2 := old2;
- raise x
+ } in
-let protect_list rvs body =
- let olds = Ext_list.map (fun (x,y) -> !x) rvs in
- let () = List.iter (fun (x,y) -> x:=y) rvs in
- try
- let res = body () in
- List.iter2 (fun (x,_) old -> x := old) rvs olds;
- res
- with e ->
- List.iter2 (fun (x,_) old -> x := old) rvs olds;
- raise e
+ check_and_transform 0 s 0 cxt;
+ let rev_segments = cxt.segments in
+ match rev_segments with
+ | [] ->
+ Exp.constant ~loc
+ (Const_string ("", Some Literals.escaped_j_delimiter))
+ | [ segment] ->
+ aux loc segment
+ | a::rest ->
+ List.fold_left (fun (acc : Parsetree.expression)
+ (x : segment) ->
+ concat_exp (aux loc x) acc )
+ (aux loc a) rest
+ with
+ Error (start,pos, error)
+ ->
+ Location.raise_errorf ~loc:(update border start pos loc )
+ "%a" pp_error error
end
module Ppx_entry : sig
@@ -18667,481 +19478,73 @@ end = struct
-(* When we design a ppx, we should keep it simple, and also think about
- how it would work with other tools like merlin and ocamldep *)
-
-(**
- 1. extension point
- {[
- [%bs.raw{| blabla |}]
- ]}
- will be desugared into
- {[
- let module Js =
- struct unsafe_js : string -> 'a end
- in Js.unsafe_js {| blabla |}
- ]}
- The major benefit is to better error reporting (with locations).
- Otherwise
-
- {[
-
- let f u = Js.unsafe_js u
- let _ = f (1 + 2)
- ]}
- And if it is inlined some where
-*)
-
-
-
-open Ast_helper
-
-
-
-
-let record_as_js_object = ref false (* otherwise has an attribute *)
-let no_export = ref false
-
-let () =
- Ast_derive_projector.init ();
- Ast_derive_js_mapper.init ()
-
-let reset () =
- record_as_js_object := false ;
- no_export := false
-
-let rec is_simple_pattern (p : Parsetree.pattern) =
- match p.ppat_desc with
- | Ppat_any -> true
- | Ppat_var _ -> true
- | Ppat_constraint(p,_) -> is_simple_pattern p
- | _ -> false
-
-let rec destruct
- acc (e : Parsetree.expression) =
- match e.pexp_desc with
- | Pexp_open (flag, lid, cont)
- ->
- destruct
- ((flag, lid, e.pexp_loc, e.pexp_attributes) :: acc)
- cont
- | Pexp_tuple es -> Some (acc, es)
- | _ -> None
-
-let newTdcls tdcls newAttrs =
- match tdcls with
- | [ x ] ->
- [{ x with Parsetree.ptype_attributes = newAttrs}]
- | _ ->
- Ext_list.map_last
- (fun last x ->
- if last then { x with Parsetree.ptype_attributes = newAttrs} else x )
- tdcls
-(*
- [let (a,b) = M.N.(c,d) ]
- =>
- [ let a = M.N.c
- and b = M.N.d ]
-*)
-let flattern_tuple_pattern_vb
- (self : Bs_ast_mapper.mapper)
- ({pvb_loc } as vb : Parsetree.value_binding)
- acc : Parsetree.value_binding list =
- let pvb_pat = self.pat self vb.pvb_pat in
- let pvb_expr = self.expr self vb.pvb_expr in
- let pvb_attributes = self.attributes self vb.pvb_attributes in
- match destruct [] pvb_expr, pvb_pat.ppat_desc with
- | Some (wholes, es), Ppat_tuple xs
- when
- List.for_all is_simple_pattern xs &&
- Ext_list.same_length es xs
- ->
- (Ext_list.fold_right2 (fun pat exp acc->
- {Parsetree.
- pvb_pat =
- pat;
- pvb_expr =
- ( match wholes with
- | [] -> exp
- | _ ->
- List.fold_left (fun x (flag,lid,loc,attrs) ->
- {Parsetree.
- pexp_desc = Pexp_open(flag,lid,x);
- pexp_attributes = attrs;
- pexp_loc = loc
- }
- ) exp wholes) ;
- pvb_attributes;
- pvb_loc ;
- } :: acc
- ) xs es) acc
- | _ ->
- {pvb_pat ;
- pvb_expr ;
- pvb_loc ;
- pvb_attributes} :: acc
+(* When we design a ppx, we should keep it simple, and also think about
+ how it would work with other tools like merlin and ocamldep *)
+(**
+ 1. extension point
+ {[
+ [%bs.raw{| blabla |}]
+ ]}
+ will be desugared into
+ {[
+ let module Js =
+ struct unsafe_js : string -> 'a end
+ in Js.unsafe_js {| blabla |}
+ ]}
+ The major benefit is to better error reporting (with locations).
+ Otherwise
+ {[
-let process_getter_setter ~no ~get ~set
- loc name
- (attrs : Ast_attributes.t)
- (ty : Parsetree.core_type) acc =
- match Ast_attributes.process_method_attributes_rev attrs with
- | {get = None; set = None}, _ -> no ty :: acc
- | st , pctf_attributes
- ->
- let get_acc =
- match st.set with
- | Some `No_get -> acc
- | None
- | Some `Get ->
- let lift txt =
- Typ.constr ~loc {txt ; loc} [ty] in
- let (null,undefined) =
- match st with
- | {get = Some (null, undefined) } -> (null, undefined)
- | {get = None} -> (false, false ) in
- let ty =
- match (null,undefined) with
- | false, false -> ty
- | true, false -> lift Ast_literal.Lid.js_null
- | false, true -> lift Ast_literal.Lid.js_undefined
- | true , true -> lift Ast_literal.Lid.js_null_undefined in
- get ty name pctf_attributes
- :: acc
- in
- if st.set = None then get_acc
- else
- set ty (name ^ Literals.setter_suffix) pctf_attributes
- :: get_acc
+ let f u = Js.unsafe_js u
+ let _ = f (1 + 2)
+ ]}
+ And if it is inlined some where
+*)
-let handle_class_type_field self
- ({pctf_loc = loc } as ctf : Parsetree.class_type_field)
- acc =
- match ctf.pctf_desc with
- | Pctf_method
- (name, private_flag, virtual_flag, ty)
- ->
- let no (ty : Parsetree.core_type) =
- let ty =
- match ty.ptyp_desc with
- | Ptyp_arrow (label, args, body)
- ->
- Ast_util.to_method_type
- ty.ptyp_loc self label args body
+open Ast_helper
- | Ptyp_poly (strs, {ptyp_desc = Ptyp_arrow (label, args, body);
- ptyp_loc})
- ->
- {ty with ptyp_desc =
- Ptyp_poly(strs,
- Ast_util.to_method_type
- ptyp_loc self label args body )}
- | _ ->
- self.typ self ty
- in
- {ctf with
- pctf_desc =
- Pctf_method (name , private_flag, virtual_flag, ty)}
- in
- let get ty name pctf_attributes =
- {ctf with
- pctf_desc =
- Pctf_method (name ,
- private_flag,
- virtual_flag,
- self.typ self ty
- );
- pctf_attributes} in
- let set ty name pctf_attributes =
- {ctf with
- pctf_desc =
- Pctf_method (name,
- private_flag,
- virtual_flag,
- Ast_util.to_method_type
- loc self "" ty
- (Ast_literal.type_unit ~loc ())
- );
- pctf_attributes} in
- process_getter_setter ~no ~get ~set loc name ctf.pctf_attributes ty acc
- | Pctf_inherit _
- | Pctf_val _
- | Pctf_constraint _
- | Pctf_attribute _
- | Pctf_extension _ ->
- Bs_ast_mapper.default_mapper.class_type_field self ctf :: acc
-(*
- Attributes are very hard to attribute
- (since ptyp_attributes could happen in so many places),
- and write ppx extensions correctly,
- we can only use it locally
-*)
-let handle_core_type
- (super : Bs_ast_mapper.mapper)
- (self : Bs_ast_mapper.mapper)
- (ty : Parsetree.core_type) =
- match ty with
- | {ptyp_desc = Ptyp_extension({txt = ("bs.obj"|"obj")}, PTyp ty)}
- ->
- Ext_ref.non_exn_protect record_as_js_object true
- (fun _ -> self.typ self ty )
- | {ptyp_attributes ;
- ptyp_desc = Ptyp_arrow (label, args, body);
- (* let it go without regard label names,
- it will report error later when the label is not empty
- *)
- ptyp_loc = loc
- } ->
- begin match Ast_attributes.process_attributes_rev ptyp_attributes with
- | `Uncurry , ptyp_attributes ->
- Ast_util.to_uncurry_type loc self label args body
- | `Meth_callback, ptyp_attributes ->
- Ast_util.to_method_callback_type loc self label args body
- | `Method, ptyp_attributes ->
- Ast_util.to_method_type loc self label args body
- | `Nothing , _ ->
- Bs_ast_mapper.default_mapper.typ self ty
- end
- | {
- ptyp_desc = Ptyp_object ( methods, closed_flag) ;
- ptyp_loc = loc
- } ->
- let (+>) attr (typ : Parsetree.core_type) =
- {typ with ptyp_attributes = attr :: typ.ptyp_attributes} in
- let new_methods =
- Ext_list.fold_right (fun (label, ptyp_attrs, core_type) acc ->
- let get ty name attrs =
- let attrs, core_type =
- match Ast_attributes.process_attributes_rev attrs with
- | `Nothing, attrs -> attrs, ty (* #1678 *)
- | `Uncurry, attrs ->
- attrs, Ast_attributes.bs +> ty
- | `Method, _
- -> Location.raise_errorf ~loc "bs.get/set conflicts with bs.meth"
- | `Meth_callback, attrs ->
- attrs, Ast_attributes.bs_this +> ty
- in
- name , attrs, self.typ self core_type in
- let set ty name attrs =
- let attrs, core_type =
- match Ast_attributes.process_attributes_rev attrs with
- | `Nothing, attrs -> attrs, ty
- | `Uncurry, attrs ->
- attrs, Ast_attributes.bs +> ty
- | `Method, _
- -> Location.raise_errorf ~loc "bs.get/set conflicts with bs.meth"
- | `Meth_callback, attrs ->
- attrs, Ast_attributes.bs_this +> ty
- in
- name, attrs, Ast_util.to_method_type loc self "" core_type
- (Ast_literal.type_unit ~loc ()) in
- let no ty =
- let attrs, core_type =
- match Ast_attributes.process_attributes_rev ptyp_attrs with
- | `Nothing, attrs -> attrs, ty
- | `Uncurry, attrs ->
- attrs, Ast_attributes.bs +> ty
- | `Method, attrs ->
- attrs, Ast_attributes.bs_method +> ty
- | `Meth_callback, attrs ->
- attrs, Ast_attributes.bs_this +> ty in
- label, attrs, self.typ self core_type in
- process_getter_setter ~no ~get ~set
- loc label ptyp_attrs core_type acc
- ) methods [] in
- let inner_type =
- { ty
- with ptyp_desc = Ptyp_object(new_methods, closed_flag);
- } in
- if !record_as_js_object then
- Ast_comb.to_js_type loc inner_type
- else inner_type
- | _ -> super.typ self ty
+let record_as_js_object = ref false (* otherwise has an attribute *)
+let no_export = ref false
+
+let () =
+ Ast_derive_projector.init ();
+ Ast_derive_js_mapper.init ()
+
+let reset () =
+ record_as_js_object := false ;
+ no_export := false
+
+
+
+let newTdcls
+ (tdcls : Parsetree.type_declaration list)
+ (newAttrs : Parsetree.attributes) : Parsetree.type_declaration list =
+ match tdcls with
+ | [ x ] ->
+ [{ x with Parsetree.ptype_attributes = newAttrs}]
+ | _ ->
+ Ext_list.map_last
+ (fun last x ->
+ if last then { x with Parsetree.ptype_attributes = newAttrs} else x )
+ tdcls
+
+
let rec unsafe_mapper : Bs_ast_mapper.mapper =
{ Bs_ast_mapper.default_mapper with
expr = (fun self ({ pexp_loc = loc } as e) ->
match e.pexp_desc with
(** Its output should not be rewritten anymore *)
- | Pexp_extension (
- {txt = ("bs.raw" | "raw"); loc} , payload)
- ->
- Ast_util.handle_raw loc payload
- | Pexp_extension (
- {txt = ("bs.re" | "re"); loc} , payload)
- ->
- Exp.constraint_ ~loc
- (Ast_util.handle_raw ~check_js_regex:true loc payload)
- (Ast_comb.to_js_re_type loc)
- | Pexp_extension ({txt = "bs.external" | "external" ; loc }, payload) ->
- begin match Ast_payload.as_ident payload with
- | Some {txt = Lident x}
- -> Ast_util.handle_external loc x
- (* do we need support [%external gg.xx ]
-
- {[ Js.Undefined.to_opt (if Js.typeof x == "undefined" then x else Js.Undefined.empty ) ]}
- *)
-
- | None | Some _ ->
- Location.raise_errorf ~loc
- "external expects a single identifier"
- end
- | Pexp_extension ({txt = "bs.time"| "time"; loc}, payload)
- ->
- (
- match payload with
- | PStr [{pstr_desc = Pstr_eval (e,_)}] ->
- let locString =
- if loc.loc_ghost then
- "GHOST LOC"
- else
- let loc_start = loc.loc_start in
- let (file, lnum, __) = Location.get_pos_info loc_start in
- Printf.sprintf "%s %d"
- file lnum in
- let e = self.expr self e in
- Exp.sequence ~loc
- (Exp.apply ~loc
- (Exp.ident ~loc {loc;
- txt =
- Ldot (Ldot (Lident "Js", "Console"), "timeStart")
- })
- ["", Exp.constant ~loc (Const_string (locString,None))]
- )
- ( Exp.let_ ~loc Nonrecursive
- [Vb.mk ~loc (Pat.var ~loc {loc; txt = "timed"}) e ;
- ]
- (Exp.sequence ~loc
- (Exp.apply ~loc
- (Exp.ident ~loc {loc;
- txt =
- Ldot (Ldot (Lident "Js", "Console"), "timeEnd")
- })
- ["", Exp.constant ~loc (Const_string (locString,None))]
- )
- (Exp.ident ~loc {loc; txt = Lident "timed"})
- )
- )
- | _ ->
- Location.raise_errorf
- ~loc "expect a boolean expression in the payload"
- )
- | Pexp_extension({txt = "bs.assert" | "assert";loc},payload)
- ->
- (
- match payload with
- | PStr [ {pstr_desc = Pstr_eval( e,_)}] ->
-
- let locString =
- if loc.loc_ghost then
- "ASSERT FAILURE"
- else
- let loc_start = loc.loc_start in
- let (file, lnum, cnum) = Location.get_pos_info loc_start in
- let enum =
- loc.Location.loc_end.Lexing.pos_cnum -
- loc_start.Lexing.pos_cnum + cnum in
- Printf.sprintf "File %S, line %d, characters %d-%d"
- file lnum cnum enum in
- let raiseWithString locString =
- (Exp.apply ~loc
- (Exp.ident ~loc {loc; txt =
- Ldot(Ldot (Lident "Js","Exn"),"raiseError")})
- ["",
-
- Exp.constant (Const_string (locString,None))
- ])
- in
- (match e.pexp_desc with
- | Pexp_construct({txt = Lident "false"},None) ->
- (* The backend will convert [assert false] into a nop later *)
- if !Clflags.no_assert_false then
- Exp.assert_ ~loc
- (Exp.construct ~loc {txt = Lident "false";loc} None)
- else
- (raiseWithString locString)
- | Pexp_constant (Const_string (r, _)) ->
- if !Clflags.noassert then
- Exp.assert_ ~loc (Exp.construct ~loc {txt = Lident "true"; loc} None)
- (* Need special handling to make it type check*)
- else
- raiseWithString r
- | _ ->
- let e = self.expr self e in
- if !Clflags.noassert then
- (* pass down so that it still type check, but the backend will
- make it a nop
- *)
- Exp.assert_ ~loc e
- else
- Exp.ifthenelse ~loc
- (Exp.apply ~loc
- (Exp.ident {loc ; txt = Ldot(Lident "Pervasives","not")})
- ["", e]
- )
- (raiseWithString locString)
- None
- )
- | _ ->
- Location.raise_errorf
- ~loc "expect a boolean expression in the payload"
- )
- (*
- [%%bs.import Bs_internalAVLSet.(a,b,c)]
- *)
- | Pexp_extension
- ({txt = ("bs.node" | "node"); loc},
- payload)
- ->
- let strip s =
- match s with
- | "_module" -> "module"
- | x -> x in
- begin match Ast_payload.as_ident payload with
- | Some {txt = Lident
- ( "__filename"
- | "__dirname"
- | "_module"
- | "require" as name); loc}
- ->
- let exp =
- Ast_util.handle_external loc (strip name) in
- let typ =
- Ast_core_type.lift_option_type
- @@
- if name = "_module" then
- Typ.constr ~loc
- { txt = Ldot (Lident "Node", "node_module") ;
- loc} []
- else if name = "require" then
- (Typ.constr ~loc
- { txt = Ldot (Lident "Node", "node_require") ;
- loc} [] )
- else
- Ast_literal.type_string ~loc () in
- Exp.constraint_ ~loc exp typ
- | Some _ | None ->
- begin match payload with
- | PTyp _ ->
- Location.raise_errorf
- ~loc "Illegal payload, expect an expression payload instead of type payload"
- | PPat _ ->
- Location.raise_errorf
- ~loc "Illegal payload, expect an expression payload instead of pattern payload"
- | _ ->
- Location.raise_errorf
- ~loc "Illegal payload"
- end
-
- end
- |Pexp_constant (Const_string (s, (Some delim)))
+ | Pexp_extension extension ->
+ Ast_exp_extension.handle_extension record_as_js_object e self extension
+ | Pexp_constant (Const_string (s, (Some delim)))
->
if Ext_string.equal delim Literals.unescaped_js_delimiter then
let js_str = Ast_utf8_string.transform loc s in
@@ -19150,27 +19553,11 @@ let rec unsafe_mapper : Bs_ast_mapper.mapper =
else if Ext_string.equal delim Literals.unescaped_j_delimiter then
Ast_utf8_string_interp.transform_interp loc s
else e
-
- (** [bs.debugger], its output should not be rewritten any more*)
- | Pexp_extension ({txt = ("bs.debugger"|"debugger"); loc} , payload)
- -> {e with pexp_desc = Ast_util.handle_debugger loc payload}
- | Pexp_extension ({txt = ("bs.obj" | "obj"); loc}, payload)
- ->
- begin match payload with
- | PStr [{pstr_desc = Pstr_eval (e,_)}]
- ->
- Ext_ref.non_exn_protect record_as_js_object true
- (fun () -> self.expr self e )
- | _ -> Location.raise_errorf ~loc "Expect an expression here"
- end
- | Pexp_extension({txt ; loc} as lid, PTyp typ)
- when Ext_string.starts_with txt Literals.bs_deriving_dot ->
- self.expr self @@
- Ast_derive.gen_expression lid typ
-
(** End rewriting *)
| Pexp_function cases ->
- begin match Ast_attributes.process_pexp_fun_attributes_rev e.pexp_attributes with
+ begin match
+ Ast_attributes.process_pexp_fun_attributes_rev e.pexp_attributes
+ with
| `Nothing, _ ->
Bs_ast_mapper.default_mapper.expr self e
| `Exn, pexp_attributes ->
@@ -19194,102 +19581,7 @@ let rec unsafe_mapper : Bs_ast_mapper.mapper =
pexp_attributes }
end
| Pexp_apply (fn, args ) ->
- begin match fn with
- | {pexp_desc =
- Pexp_apply (
- {pexp_desc =
- Pexp_ident {txt = Lident "##" ; loc} ; _},
- [("", obj) ;
- ("", {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _} )
- ]);
- _} -> (* f##paint 1 2 *)
- {e with pexp_desc = Ast_util.method_apply loc self obj name args }
- | {pexp_desc =
- Pexp_apply (
- {pexp_desc =
- Pexp_ident {txt = Lident "#@" ; loc} ; _},
- [("", obj) ;
- ("", {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _} )
- ]);
- _} -> (* f##paint 1 2 *)
- {e with pexp_desc = Ast_util.property_apply loc self obj name args }
-
- | {pexp_desc =
- Pexp_ident {txt = Lident "##" ; loc} ; _}
- ->
- begin match args with
- | [("", obj) ;
- ("", {pexp_desc = Pexp_apply(
- {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _},
- args
- ); pexp_attributes = attrs }
- (* we should warn when we discard attributes *)
- )
- ] -> (* f##(paint 1 2 ) *)
- (* gpr#1063 foo##(bar##baz) we should rewrite (bar##baz)
- first before pattern match.
- currently the pattern match is written in a top down style.
- Another corner case: f##(g a b [@bs])
- *)
- Bs_ast_invariant.warn_unused_attributes attrs ;
- {e with pexp_desc = Ast_util.method_apply loc self obj name args}
- | [("", obj) ;
- ("",
- {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _}
- ) (* f##paint *)
- ] ->
- { e with pexp_desc =
- Ast_util.js_property loc (self.expr self obj) name
- }
-
- | _ ->
- Location.raise_errorf ~loc
- "Js object ## expect syntax like obj##(paint (a,b)) "
- end
- (* we can not use [:=] for precedece cases
- like {[i @@ x##length := 3 ]}
- is parsed as {[ (i @@ x##length) := 3]}
- since we allow user to create Js objects in OCaml, it can be of
- ref type
- {[
- let u = object (self)
- val x = ref 3
- method setX x = self##x := 32
- method getX () = !self##x
- end
- ]}
- *)
- | {pexp_desc =
- Pexp_ident {txt = Lident ("#=" )}
- } ->
- begin match args with
- | ["",
- {pexp_desc =
- Pexp_apply ({pexp_desc = Pexp_ident {txt = Lident "##"}},
- ["", obj;
- "", {pexp_desc = Pexp_ident {txt = Lident name}}
- ]
- )};
- "", arg
- ] ->
- Exp.constraint_ ~loc
- { e with
- pexp_desc =
- Ast_util.method_apply loc self obj
- (name ^ Literals.setter_suffix) ["", arg ] }
- (Ast_literal.type_unit ~loc ())
- | _ -> Bs_ast_mapper.default_mapper.expr self e
- end
- | _ ->
- begin match
- Ext_list.exclude_with_val
- Ast_attributes.is_bs e.pexp_attributes with
- | false, _ -> Bs_ast_mapper.default_mapper.expr self e
- | true, pexp_attributes ->
- {e with pexp_desc = Ast_util.uncurry_fn_apply loc self fn args ;
- pexp_attributes }
- end
- end
+ Ast_exp_apply.handle_exp_apply e self fn args
| Pexp_record (label_exprs, opt_exp) ->
if !record_as_js_object then
(match opt_exp with
@@ -19325,7 +19617,8 @@ let rec unsafe_mapper : Bs_ast_mapper.mapper =
end
| _ -> Bs_ast_mapper.default_mapper.expr self e
);
- typ = (fun self typ -> handle_core_type Bs_ast_mapper.default_mapper self typ);
+ typ = (fun self typ ->
+ Ast_core_type_class_type.handle_core_type self typ record_as_js_object);
class_type =
(fun self ({pcty_attributes; pcty_loc} as ctd) ->
match Ast_attributes.process_bs pcty_attributes with
@@ -19340,7 +19633,7 @@ let rec unsafe_mapper : Bs_ast_mapper.mapper =
{ctd with
pcty_desc = Pcty_signature {
pcsig_self ;
- pcsig_fields = Ext_list.fold_right (handle_class_type_field self) pcsig_fields []
+ pcsig_fields = Ast_core_type_class_type.handle_class_type_fields self pcsig_fields
};
pcty_attributes
}
@@ -19438,12 +19731,7 @@ let rec unsafe_mapper : Bs_ast_mapper.mapper =
| _ -> Bs_ast_mapper.default_mapper.pat self pat
end;
- value_bindings = begin fun self (vbs : Parsetree.value_binding list) ->
- (* Bs_ast_mapper.default_mapper.value_bindings self vbs *)
- List.fold_right (fun vb acc ->
- flattern_tuple_pattern_vb self vb acc
- ) vbs []
- end;
+ value_bindings = Ast_tuple_pattern_flatten.handle_value_bindings;
structure_item = begin fun self (str : Parsetree.structure_item) ->
begin match str.pstr_desc with
| Pstr_extension ( ({txt = ("bs.raw"| "raw") ; loc}, payload), _attrs)
diff --git a/lib/whole_compiler.d b/lib/whole_compiler.d
index 7a8761be24..7186d0bade 100644
--- a/lib/whole_compiler.d
+++ b/lib/whole_compiler.d
@@ -255,6 +255,7 @@
../lib/whole_compiler.ml : ./depends/bs_exception.ml
../lib/whole_compiler.ml : ./ext/string_hash_set.mli
../lib/whole_compiler.ml : ./syntax/ast_core_type.ml
+../lib/whole_compiler.ml : ./syntax/ast_exp_apply.ml
../lib/whole_compiler.ml : ./syntax/ast_signature.ml
../lib/whole_compiler.ml : ./syntax/ast_structure.ml
../lib/whole_compiler.ml : ./syntax/bs_ast_mapper.ml
@@ -295,6 +296,7 @@
../lib/whole_compiler.ml : ./depends/bs_exception.mli
../lib/whole_compiler.ml : ./syntax/ast_attributes.ml
../lib/whole_compiler.ml : ./syntax/ast_core_type.mli
+../lib/whole_compiler.ml : ./syntax/ast_exp_apply.mli
../lib/whole_compiler.ml : ./syntax/ast_signature.mli
../lib/whole_compiler.ml : ./syntax/ast_structure.mli
../lib/whole_compiler.ml : ./syntax/bs_ast_mapper.mli
@@ -393,6 +395,7 @@
../lib/whole_compiler.ml : ./ext/hash_set_ident_mask.mli
../lib/whole_compiler.ml : ./ext/ordered_hash_map_gen.ml
../lib/whole_compiler.ml : ./super_errors/super_misc.mli
+../lib/whole_compiler.ml : ./syntax/ast_exp_extension.ml
../lib/whole_compiler.ml : ./syntax/bs_ast_invariant.mli
../lib/whole_compiler.ml : ./syntax/external_arg_spec.ml
../lib/whole_compiler.ml : ./syntax/external_process.mli
@@ -417,6 +420,7 @@
../lib/whole_compiler.ml : ./core/lam_compile_context.mli
../lib/whole_compiler.ml : ./core/ocaml_batch_compile.mli
../lib/whole_compiler.ml : ./super_errors/super_pparse.ml
+../lib/whole_compiler.ml : ./syntax/ast_exp_extension.mli
../lib/whole_compiler.ml : ./syntax/external_arg_spec.mli
../lib/whole_compiler.ml : ./syntax/external_ffi_types.ml
../lib/whole_compiler.ml : ../vendor/ocaml/bytecomp/translcore.ml
@@ -479,9 +483,13 @@
../lib/whole_compiler.ml : ./core/lam_compile_external_call.mli
../lib/whole_compiler.ml : ./core/lam_pass_alpha_conversion.mli
../lib/whole_compiler.ml : ./super_errors/super_reason_react.ml
+../lib/whole_compiler.ml : ./syntax/ast_core_type_class_type.ml
../lib/whole_compiler.ml : ./ext/ordered_hash_map_local_ident.ml
../lib/whole_compiler.ml : ./super_errors/super_reason_react.mli
+../lib/whole_compiler.ml : ./syntax/ast_core_type_class_type.mli
+../lib/whole_compiler.ml : ./syntax/ast_tuple_pattern_flatten.ml
../lib/whole_compiler.ml : ./ext/ordered_hash_map_local_ident.mli
+../lib/whole_compiler.ml : ./syntax/ast_tuple_pattern_flatten.mli
../lib/whole_compiler.ml : ./core/js_pass_flatten_and_mark_dead.ml
../lib/whole_compiler.ml : ./outcome_printer/outcome_printer_ns.ml
../lib/whole_compiler.ml : ./core/js_pass_flatten_and_mark_dead.mli
diff --git a/lib/whole_compiler.ml b/lib/whole_compiler.ml
index e83b26de42..297c9d9781 100644
--- a/lib/whole_compiler.ml
+++ b/lib/whole_compiler.ml
@@ -105404,8 +105404,8 @@ let bs_set : attr
end
-module Ast_signature : sig
-#1 "ast_signature.mli"
+module Ast_exp : sig
+#1 "ast_exp.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -105430,13 +105430,10 @@ module Ast_signature : sig
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-type item = Parsetree.signature_item
-type t = item list
-
+type t = Parsetree.expression
-val fuseAll : ?loc:Ast_helper.loc -> t -> item
end = struct
-#1 "ast_signature.ml"
+#1 "ast_exp.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -105461,17 +105458,11 @@ end = struct
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-type item = Parsetree.signature_item
-type t = item list
-
-open Ast_helper
+type t = Parsetree.expression
-let fuseAll ?(loc=Location.none) (t : t) : item =
- Sig.include_ ~loc (Incl.mk ~loc (Mty.signature ~loc t))
-
end
-module Ast_structure : sig
-#1 "ast_structure.mli"
+module Ast_external_mk : sig
+#1 "ast_external_mk.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -105496,25 +105487,35 @@ module Ast_structure : sig
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
+(**
+ [local_module loc ~pval_prim ~pval_type args]
+ generate such code
+ {[
+ let module J = struct
+ external unsafe_expr : pval_type = pval_prim
+ end in
+ J.unssafe_expr args
+ ]}
+*)
+val local_external : Location.t ->
+ ?pval_attributes:Parsetree.attributes ->
+ pval_prim:string list ->
+ pval_type:Parsetree.core_type ->
+ ?local_module_name:string ->
+ ?local_fun_name:string ->
+ (string * Parsetree.expression) list -> Parsetree.expression_desc
-type item = Parsetree.structure_item
-
-type t = item list
-
-
-val fuseAll: ?loc:Ast_helper.loc -> t -> item
-
-(* val fuse_with_constraint:
- ?loc:Ast_helper.loc ->
- Parsetree.type_declaration list ->
- t ->
- Ast_signature.t ->
- item *)
-
-val constraint_ : ?loc:Ast_helper.loc -> t -> Ast_signature.t -> item
+val local_extern_cont :
+ Location.t ->
+ ?pval_attributes:Parsetree.attributes ->
+ pval_prim:string list ->
+ pval_type:Parsetree.core_type ->
+ ?local_module_name:string ->
+ ?local_fun_name:string ->
+ (Parsetree.expression -> Parsetree.expression) -> Parsetree.expression_desc
end = struct
-#1 "ast_structure.ml"
+#1 "ast_external_mk.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -105539,39 +105540,73 @@ end = struct
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-type item = Parsetree.structure_item
-
-type t = item list
-
-open Ast_helper
-
+let 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_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 fuseAll ?(loc=Location.none) (t : t) : item =
- Str.include_ ~loc
- (Incl.mk ~loc (Mod.structure ~loc t ))
-
-(* let fuse_with_constraint
- ?(loc=Location.none)
- (item : Parsetree.type_declaration list ) (t : t) (coercion) =
- Str.include_ ~loc
- (Incl.mk ~loc
- (Mod.constraint_
- (Mod.structure ~loc
- ({pstr_loc = loc; pstr_desc = Pstr_type item} :: t) )
- (
- Mty.signature ~loc
- ({psig_loc = loc; psig_desc = Psig_type item} :: coercion)
- )
- )
- ) *)
-let constraint_ ?(loc=Location.none) (stru : t) (sign : Ast_signature.t) =
- Str.include_ ~loc
- (Incl.mk ~loc
- (Mod.constraint_ ~loc (Mod.structure ~loc stru) (Mty.signature ~loc sign)))
+let local_extern_cont loc
+ ?(pval_attributes=[])
+ ~pval_prim
+ ~pval_type
+ ?(local_module_name = "J")
+ ?(local_fun_name = "unsafe_expr")
+ (cb : Parsetree.expression -> 'a)
+ : 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_attributes };
+ pstr_loc = loc;
+ }];
+ pmod_loc = loc;
+ pmod_attributes = []},
+ cb {pexp_desc = Pexp_ident {txt = Ldot (Lident local_module_name, local_fun_name);
+ loc};
+ pexp_attributes = [] ;
+ pexp_loc = loc}
+)
end
-module Ast_derive : sig
-#1 "ast_derive.mli"
+module Ast_pat : sig
+#1 "ast_pat.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -105596,51 +105631,19 @@ module Ast_derive : sig
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-type tdcls = Parsetree.type_declaration list
-
-type gen = {
- structure_gen : tdcls -> bool -> Ast_structure.t ;
- signature_gen : tdcls -> bool -> Ast_signature.t ;
- expression_gen : (Parsetree.core_type -> Parsetree.expression) option ;
-}
-
-(**
- [register name cb]
- example: [register "accessors" cb]
-*)
-val register :
- string ->
- (Parsetree.expression option -> gen) ->
- unit
-
-(* val gen_structure:
- tdcls ->
- Ast_payload.action list ->
- bool ->
- Ast_structure.t *)
-
-val gen_signature:
- tdcls ->
- Ast_payload.action list ->
- bool ->
- Ast_signature.t
+type t = Parsetree.pattern
+val is_unit_cont : yes:'a -> no:'a -> t -> 'a
-val gen_expression :
- string Asttypes.loc ->
- Parsetree.core_type ->
- Parsetree.expression
+(** [arity_of_fun pat e] tells the arity of
+ expression [fun pat -> e]*)
+val arity_of_fun : t -> Parsetree.expression -> int
+val is_single_variable_pattern_conservative : t -> bool
-val gen_structure_signature :
- Location.t ->
- Parsetree.type_declaration list ->
- Ast_payload.action ->
- bool ->
- Parsetree.structure_item
end = struct
-#1 "ast_derive.ml"
+#1 "ast_pat.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -105665,602 +105668,813 @@ end = struct
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-type tdcls = Parsetree.type_declaration list
-
-type gen = {
- structure_gen : tdcls -> bool -> Ast_structure.t ;
- signature_gen : tdcls -> bool -> Ast_signature.t ;
- expression_gen : (Parsetree.core_type -> Parsetree.expression) option ;
-}
-(* the first argument is [config] payload
- {[
- { x = {uu} }
- ]}
-*)
-type derive_table =
- (Parsetree.expression option -> gen) String_map.t
+type t = Parsetree.pattern
-let derive_table : derive_table ref = ref String_map.empty
-let register key value =
- derive_table := String_map.add key value !derive_table
+let is_unit_cont ~yes ~no (p : t) =
+ match p with
+ | {ppat_desc = Ppat_construct({txt = Lident "()"}, None)}
+ -> yes
+ | _ -> no
+(** [arity_of_fun pat e] tells the arity of
+ expression [fun pat -> e]
+*)
+let arity_of_fun
+ (pat : Parsetree.pattern)
+ (e : Parsetree.expression) =
+ let rec aux (e : Parsetree.expression) =
+ match e.pexp_desc with
+ | Pexp_fun ("", None, pat, e) ->
+ 1 + aux e
+ | Pexp_fun _
+ -> Location.raise_errorf
+ ~loc:e.pexp_loc "Label is not allowed in JS object"
+ | _ -> 0 in
+ is_unit_cont ~yes:0 ~no:1 pat + aux e
-(* let gen_structure
- (tdcls : tdcls)
- (actions : Ast_payload.action list )
- (explict_nonrec : bool )
- : Ast_structure.t =
- Ext_list.flat_map
- (fun action ->
- (Ast_payload.table_dispatch !derive_table action).structure_gen
- tdcls explict_nonrec) actions *)
-let gen_signature
- tdcls
- (actions : Ast_payload.action list )
- (explict_nonrec : bool )
- : Ast_signature.t =
- Ext_list.flat_map
- (fun action ->
- (Ast_payload.table_dispatch !derive_table action).signature_gen
- tdcls explict_nonrec) actions
+let rec is_single_variable_pattern_conservative (p : t ) =
+ match p.ppat_desc with
+ | Parsetree.Ppat_any
+ | Parsetree.Ppat_var _ -> true
+ | Parsetree.Ppat_alias (p,_)
+ | Parsetree.Ppat_constraint (p, _) ->
+ is_single_variable_pattern_conservative p
+
+ | _ -> false
-(** used for cases like [%sexp] *)
-let gen_expression ({Asttypes.txt ; loc}) typ =
- let txt = Ext_string.tail_from txt (String.length Literals.bs_deriving_dot) in
- match (Ast_payload.table_dispatch !derive_table
- ({txt ; loc}, None)).expression_gen with
- | None ->
- Bs_syntaxerr.err loc (Unregistered txt)
+end
+module Bs_ast_mapper : sig
+#1 "bs_ast_mapper.mli"
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
- | Some f -> f typ
+(** The interface of a -ppx rewriter
-open Ast_helper
-let gen_structure_signature
- loc
- (tdcls : tdcls)
- (action : Ast_payload.action)
- (explicit_nonrec : bool) =
- let derive_table = !derive_table in
- let u =
- Ast_payload.table_dispatch derive_table action in
+ A -ppx rewriter is a program that accepts a serialized abstract syntax
+ tree and outputs another, possibly modified, abstract syntax tree.
+ This module encapsulates the interface between the compiler and
+ the -ppx rewriters, handling such details as the serialization format,
+ forwarding of command-line flags, and storing state.
- let a = u.structure_gen tdcls explicit_nonrec in
- let b = u.signature_gen tdcls explicit_nonrec in
- Str.include_ ~loc
- (Incl.mk ~loc
- (Mod.constraint_ ~loc
- (Mod.structure ~loc a)
- (Mty.signature ~loc b )
- )
- )
-end
-module Ast_derive_util : sig
-#1 "ast_derive_util.mli"
-(* Copyright (C) 2017 Authors of BuckleScript
- *
- * 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. *)
+ {!mapper} allows to implement AST rewriting using open recursion.
+ A typical mapper would be based on {!default_mapper}, a deep
+ identity mapper, and will fall back on it for handling the syntax it
+ does not modify. For example:
-(** Given a type declaration, extaract the type expression, mostly
- used in code gen later
- *)
- val core_type_of_type_declaration :
- Parsetree.type_declaration -> Parsetree.core_type
+ {[
+open Asttypes
+open Parsetree
+open Ast_mapper
-val new_type_of_type_declaration :
- Parsetree.type_declaration ->
- string ->
- Parsetree.core_type * Parsetree.type_declaration
+let test_mapper argv =
+ { default_mapper with
+ expr = fun mapper expr ->
+ match expr with
+ | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} ->
+ Ast_helper.Exp.constant (Const_int 42)
+ | other -> default_mapper.expr mapper other; }
-val lift_string_list_to_array : string list -> Parsetree.expression
-val lift_int : int -> Parsetree.expression
-val lift_int_list_to_array : int list -> Parsetree.expression
-val mk_fun :
- loc:Location.t ->
- Parsetree.core_type ->
- string -> Parsetree.expression -> Parsetree.expression
-val destruct_label_declarations :
- loc:Location.t ->
- string ->
- Parsetree.label_declaration list ->
- (Parsetree.core_type * Parsetree.expression) list * string list
+let () =
+ register "ppx_test" test_mapper]}
-val notApplicable:
- Location.t ->
- string ->
- unit
+ This -ppx rewriter, which replaces [[%test]] in expressions with
+ the constant [42], can be compiled using
+ [ocamlc -o ppx_test -I +compiler-libs ocamlcommon.cma ppx_test.ml].
-val invalid_config : Parsetree.expression -> 'a
+ *)
+
+ open Parsetree
+
+ (** {2 A generic Parsetree mapper} *)
+
+ type mapper = {
+ attribute: mapper -> attribute -> attribute;
+ attributes: mapper -> attribute list -> attribute list;
+ case: mapper -> case -> case;
+ cases: mapper -> case list -> case list;
+ class_declaration: mapper -> class_declaration -> class_declaration;
+ class_description: mapper -> class_description -> class_description;
+ class_expr: mapper -> class_expr -> class_expr;
+ class_field: mapper -> class_field -> class_field;
+ class_signature: mapper -> class_signature -> class_signature;
+ class_structure: mapper -> class_structure -> class_structure;
+ class_type: mapper -> class_type -> class_type;
+ class_type_declaration: mapper -> class_type_declaration
+ -> class_type_declaration;
+ class_type_field: mapper -> class_type_field -> class_type_field;
+ constructor_declaration: mapper -> constructor_declaration
+ -> constructor_declaration;
+ expr: mapper -> expression -> expression;
+ extension: mapper -> extension -> extension;
+ extension_constructor: mapper -> extension_constructor
+ -> extension_constructor;
+ include_declaration: mapper -> include_declaration -> include_declaration;
+ include_description: mapper -> include_description -> include_description;
+ label_declaration: mapper -> label_declaration -> label_declaration;
+ location: mapper -> Location.t -> Location.t;
+ module_binding: mapper -> module_binding -> module_binding;
+ module_declaration: mapper -> module_declaration -> module_declaration;
+ module_expr: mapper -> module_expr -> module_expr;
+ module_type: mapper -> module_type -> module_type;
+ module_type_declaration: mapper -> module_type_declaration
+ -> module_type_declaration;
+ open_description: mapper -> open_description -> open_description;
+ pat: mapper -> pattern -> pattern;
+ payload: mapper -> payload -> payload;
+ signature: mapper -> signature -> signature;
+ signature_item: mapper -> signature_item -> signature_item;
+ structure: mapper -> structure -> structure;
+ structure_item: mapper -> structure_item -> structure_item;
+ typ: mapper -> core_type -> core_type;
+ type_declaration: mapper -> type_declaration -> type_declaration;
+ type_extension: mapper -> type_extension -> type_extension;
+ type_kind: mapper -> type_kind -> type_kind;
+ value_binding: mapper -> value_binding -> value_binding;
+(* XXXXX *)
+ value_bindings_rec: mapper -> value_binding list -> value_binding list;
+ value_bindings: mapper -> value_binding list -> value_binding list;
+(* XXXXX *)
+ value_description: mapper -> value_description -> value_description;
+ with_constraint: mapper -> with_constraint -> with_constraint;
+ }
+ (** A mapper record implements one "method" per syntactic category,
+ using an open recursion style: each method takes as its first
+ argument the mapper to be applied to children in the syntax
+ tree. *)
+
+ val default_mapper: mapper
+ (** A default mapper, which implements a "deep identity" mapping. *)
+
end = struct
-#1 "ast_derive_util.ml"
-(* 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. *)
+#1 "bs_ast_mapper.ml"
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Alain Frisch, LexiFi *)
+(* *)
+(* Copyright 2012 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
-open Ast_helper
+(* A generic Parsetree mapping class *)
+(* Adapted for BUcklescript with more flexibilty*)
-let core_type_of_type_declaration
- (tdcl : Parsetree.type_declaration) =
- match tdcl with
- | {ptype_name = {txt ; loc};
- ptype_params ;
- } ->
- Typ.constr
- {txt = Lident txt ; loc}
- (Ext_list.map fst ptype_params)
+[@@@ocaml.warning "+9"]
+(* Ensure that record patterns don't miss any field. *)
-let new_type_of_type_declaration
- (tdcl : Parsetree.type_declaration) newName =
- match tdcl with
- | {ptype_name = { loc};
- ptype_params ;
- } ->
- (Typ.constr
- {txt = Lident newName ; loc}
- (Ext_list.map fst ptype_params),
- { Parsetree.ptype_params = tdcl.ptype_params;
- ptype_name = {txt = newName;loc};
- ptype_kind = Ptype_abstract;
- ptype_attributes = [];
- ptype_loc = tdcl.ptype_loc;
- ptype_cstrs = []; ptype_private = Public; ptype_manifest = None}
- )
-
-let lift_string_list_to_array (labels : string list) =
- Exp.array
- (Ext_list.map (fun s -> Exp.constant (Const_string (s, None)))
- labels)
-let lift_int i = Exp.constant (Const_int i)
-let lift_int_list_to_array (labels : int list) =
- Exp.array (Ext_list.map lift_int labels)
+open Asttypes
+open Parsetree
+open Ast_helper
+open Location
+type mapper = {
+ attribute: mapper -> attribute -> attribute;
+ attributes: mapper -> attribute list -> attribute list;
+ case: mapper -> case -> case;
+ cases: mapper -> case list -> case list;
+ class_declaration: mapper -> class_declaration -> class_declaration;
+ class_description: mapper -> class_description -> class_description;
+ class_expr: mapper -> class_expr -> class_expr;
+ class_field: mapper -> class_field -> class_field;
+ class_signature: mapper -> class_signature -> class_signature;
+ class_structure: mapper -> class_structure -> class_structure;
+ class_type: mapper -> class_type -> class_type;
+ class_type_declaration: mapper -> class_type_declaration
+ -> class_type_declaration;
+ class_type_field: mapper -> class_type_field -> class_type_field;
+ constructor_declaration: mapper -> constructor_declaration
+ -> constructor_declaration;
+ expr: mapper -> expression -> expression;
+ extension: mapper -> extension -> extension;
+ extension_constructor: mapper -> extension_constructor
+ -> extension_constructor;
+ include_declaration: mapper -> include_declaration -> include_declaration;
+ include_description: mapper -> include_description -> include_description;
+ label_declaration: mapper -> label_declaration -> label_declaration;
+ location: mapper -> Location.t -> Location.t;
+ module_binding: mapper -> module_binding -> module_binding;
+ module_declaration: mapper -> module_declaration -> module_declaration;
+ module_expr: mapper -> module_expr -> module_expr;
+ module_type: mapper -> module_type -> module_type;
+ module_type_declaration: mapper -> module_type_declaration
+ -> module_type_declaration;
+ open_description: mapper -> open_description -> open_description;
+ pat: mapper -> pattern -> pattern;
+ payload: mapper -> payload -> payload;
+ signature: mapper -> signature -> signature;
+ signature_item: mapper -> signature_item -> signature_item;
+ structure: mapper -> structure -> structure;
+ structure_item: mapper -> structure_item -> structure_item;
+ typ: mapper -> core_type -> core_type;
+ type_declaration: mapper -> type_declaration -> type_declaration;
+ type_extension: mapper -> type_extension -> type_extension;
+ type_kind: mapper -> type_kind -> type_kind;
+ value_binding: mapper -> value_binding -> value_binding;
+(* XXXX *)
+ value_bindings_rec : mapper -> value_binding list -> value_binding list;
+ value_bindings : mapper -> value_binding list -> value_binding list;
+(* XXXXX *)
+ value_description: mapper -> value_description -> value_description;
+ with_constraint: mapper -> with_constraint -> with_constraint;
+}
-let mk_fun ~loc (typ : Parsetree.core_type)
- (value : string) body
- : Parsetree.expression =
- Exp.fun_
- "" None
- (Pat.constraint_ (Pat.var {txt = value ; loc}) typ)
- body
+let map_fst f (x, y) = (f x, y)
+let map_snd f (x, y) = (x, f y)
+let map_tuple f1 f2 (x, y) = (f1 x, f2 y)
+let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
+let map_opt f = function None -> None | Some x -> Some (f x)
-let destruct_label_declarations ~loc
- (arg_name : string)
- (labels : Parsetree.label_declaration list) :
- (Parsetree.core_type * Parsetree.expression) list * string list
- =
- Ext_list.fold_right
- (fun ({pld_name = {txt}; pld_type} : Parsetree.label_declaration)
- (core_type_exps, labels) ->
- ((pld_type,
- Exp.field (Exp.ident {txt = Lident arg_name ; loc})
- {txt = Lident txt ; loc}) :: core_type_exps),
- txt :: labels
- ) labels ([], [])
+let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt}
-let notApplicable
- loc derivingName =
- Location.prerr_warning
- loc
- (Warnings.Bs_derive_warning ( derivingName ^ " not applicable to this type"))
-
-let invalid_config (config : Parsetree.expression) =
- Location.raise_errorf ~loc:config.pexp_loc "such configuration is not supported"
-
-end
-module Ast_derive_abstract : sig
-#1 "ast_derive_abstract.mli"
-(* Copyright (C) 2017 Authors of BuckleScript
- *
- * 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 T = struct
+ (* Type expressions for the core language *)
-val handleTdclsInStr :
- Parsetree.type_declaration list -> Parsetree.structure
+ let row_field sub = function
+ | Rtag (l, attrs, b, tl) ->
+ Rtag (l, sub.attributes sub attrs, b, List.map (sub.typ sub) tl)
+ | Rinherit t -> Rinherit (sub.typ sub t)
-val handleTdclsInSig:
- Parsetree.type_declaration list -> Parsetree.signature
-end = struct
-#1 "ast_derive_abstract.ml"
-(* Copyright (C) 2017 Authors of BuckleScript
- *
- * 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 map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} =
+ let open Typ in
+ let loc = sub.location sub loc in
+ let attrs = sub.attributes sub attrs in
+ match desc with
+ | Ptyp_any -> any ~loc ~attrs ()
+ | Ptyp_var s -> var ~loc ~attrs s
+ | Ptyp_arrow (lab, t1, t2) ->
+ arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2)
+ | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl)
+ | Ptyp_constr (lid, tl) ->
+ constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
+ | Ptyp_object (l, o) ->
+ let f (s, a, t) = (s, sub.attributes sub a, sub.typ sub t) in
+ object_ ~loc ~attrs (List.map f l) o
+ | Ptyp_class (lid, tl) ->
+ class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
+ | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s
+ | Ptyp_variant (rl, b, ll) ->
+ variant ~loc ~attrs (List.map (row_field sub) rl) b ll
+ | Ptyp_poly (sl, t) -> poly ~loc ~attrs sl (sub.typ sub t)
+ | Ptyp_package (lid, l) ->
+ package ~loc ~attrs (map_loc sub lid)
+ (List.map (map_tuple (map_loc sub) (sub.typ sub)) l)
+ | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x)
+ let map_type_declaration sub
+ {ptype_name; ptype_params; ptype_cstrs;
+ ptype_kind;
+ ptype_private;
+ ptype_manifest;
+ ptype_attributes;
+ ptype_loc} =
+ Type.mk (map_loc sub ptype_name)
+ ~params:(List.map (map_fst (sub.typ sub)) ptype_params)
+ ~priv:ptype_private
+ ~cstrs:(List.map
+ (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub))
+ ptype_cstrs)
+ ~kind:(sub.type_kind sub ptype_kind)
+ ?manifest:(map_opt (sub.typ sub) ptype_manifest)
+ ~loc:(sub.location sub ptype_loc)
+ ~attrs:(sub.attributes sub ptype_attributes)
-let derivingName = "abstract"
-module U = Ast_derive_util
-open Ast_helper
-type tdcls = Parsetree.type_declaration list
+ let map_type_kind sub = function
+ | Ptype_abstract -> Ptype_abstract
+ | Ptype_variant l ->
+ Ptype_variant (List.map (sub.constructor_declaration sub) l)
+ | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l)
+ | Ptype_open -> Ptype_open
-let handle_config (config : Parsetree.expression option) =
- match config with
- | Some config ->
- U.invalid_config config
- | None -> ()
+ let map_type_extension sub
+ {ptyext_path; ptyext_params;
+ ptyext_constructors;
+ ptyext_private;
+ ptyext_attributes} =
+ Te.mk
+ (map_loc sub ptyext_path)
+ (List.map (sub.extension_constructor sub) ptyext_constructors)
+ ~params:(List.map (map_fst (sub.typ sub)) ptyext_params)
+ ~priv:ptyext_private
+ ~attrs:(sub.attributes sub ptyext_attributes)
-(* see #2337
- TODO: relax it to allow (int -> int [@bs])
-*)
-let rec checkNotFunciton (ty : Parsetree.core_type) =
- match ty.ptyp_desc with
- | Ptyp_poly (_,ty) -> checkNotFunciton ty
- | Ptyp_alias (ty,_) -> checkNotFunciton ty
- | Ptyp_arrow _ ->
- Location.raise_errorf
- ~loc:ty.ptyp_loc
- "syntactic function type is not allowed when working with abstract bs.deriving, create a named type as work around"
- | Ptyp_any
- | Ptyp_var _
- | Ptyp_tuple _
- | Ptyp_constr _
- | Ptyp_object _
- | Ptyp_class _
- | Ptyp_variant _
- | Ptyp_package _
- | Ptyp_extension _ -> ()
-let handleTdcl (tdcl : Parsetree.type_declaration) =
- let core_type = U.core_type_of_type_declaration tdcl in
- let loc = tdcl.ptype_loc in
- let name = tdcl.ptype_name.txt in
- let newTdcl = {
- tdcl with
- ptype_kind = Ptype_abstract;
- ptype_attributes = [];
- (* avoid non-terminating*)
- } in
- match tdcl.ptype_kind with
- | Ptype_record label_declarations ->
- let ty =
- Ext_list.fold_right (fun (label_declaration : Parsetree.label_declaration) acc ->
- Typ.arrow
- label_declaration.pld_name.txt label_declaration.pld_type acc
- ) label_declarations core_type in
- let setter_accessor =
- Ext_list.fold_right (fun (x: Parsetree.label_declaration) acc ->
- let pld_name = x.pld_name.txt in
- let pld_loc = x.pld_name.loc in
- let pld_type = x.pld_type in
- let () = checkNotFunciton pld_type in
- let setter =
- Val.mk
- {loc = pld_loc; txt = pld_name}
- ~attrs:[Ast_attributes.bs_get]
- ~prim:[pld_name]
- (Typ.arrow "" core_type pld_type) :: acc in
- match x.pld_mutable with
- | Mutable ->
- Val.mk
- {loc = pld_loc; txt = pld_name ^ "Set"}
- ~attrs:[Ast_attributes.bs_set]
- ~prim:[pld_name]
- (Typ.arrow "" core_type (Typ.arrow "" pld_type (Ast_literal.type_unit ()))) :: setter
- | Immutable -> setter
- ) label_declarations []
- in
+ let map_extension_constructor_kind sub = function
+ Pext_decl(ctl, cto) ->
+ Pext_decl(List.map (sub.typ sub) ctl, map_opt (sub.typ sub) cto)
+ | Pext_rebind li ->
+ Pext_rebind (map_loc sub li)
- newTdcl,
- (match tdcl.ptype_private with
- | Private -> setter_accessor
- | Public ->
- let maker =
- Val.mk {loc; txt = name}
- ~attrs:[Ast_attributes.bs_obj]
- ~prim:[""] ty in
- (maker :: setter_accessor))
+ let map_extension_constructor sub
+ {pext_name;
+ pext_kind;
+ pext_loc;
+ pext_attributes} =
+ Te.constructor
+ (map_loc sub pext_name)
+ (map_extension_constructor_kind sub pext_kind)
+ ~loc:(sub.location sub pext_loc)
+ ~attrs:(sub.attributes sub pext_attributes)
- | Ptype_abstract
- | Ptype_variant _
- | Ptype_open ->
- (* Looks obvious that it does not make sense to warn *)
- (* U.notApplicable tdcl.ptype_loc derivingName; *)
- tdcl, []
+end
-let handleTdclsInStr tdcls =
- let tdcls, code =
- List.fold_right (fun tdcl (tdcls, sts) ->
- match handleTdcl tdcl with
- ntdcl, value_descriptions ->
- ntdcl::tdcls,
- Ext_list.map_append (fun x -> Str.primitive x) value_descriptions sts
+module CT = struct
+ (* Type expressions for the class language *)
- ) tdcls ([],[]) in
- Str.type_ tdcls :: code
-(* still need perform transformation for non-abstract type*)
+ let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} =
+ let open Cty in
+ let loc = sub.location sub loc in
+ let attrs = sub.attributes sub attrs in
+ match desc with
+ | Pcty_constr (lid, tys) ->
+ constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys)
+ | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x)
+ | Pcty_arrow (lab, t, ct) ->
+ arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct)
+ | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x)
-let handleTdclsInSig tdcls =
- let tdcls, code =
- List.fold_right (fun tdcl (tdcls, sts) ->
- match handleTdcl tdcl with
- ntdcl, value_descriptions ->
- ntdcl::tdcls,
- Ext_list.map_append (fun x -> Sig.value x) value_descriptions sts
+ let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs}
+ =
+ let open Ctf in
+ let loc = sub.location sub loc in
+ let attrs = sub.attributes sub attrs in
+ match desc with
+ | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct)
+ | Pctf_val (s, m, v, t) -> val_ ~loc ~attrs s m v (sub.typ sub t)
+ | Pctf_method (s, p, v, t) -> method_ ~loc ~attrs s p v (sub.typ sub t)
+ | Pctf_constraint (t1, t2) ->
+ constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2)
+ | Pctf_attribute x -> attribute ~loc (sub.attribute sub x)
+ | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x)
- ) tdcls ([],[]) in
- Sig.type_ tdcls :: code
+ let map_signature sub {pcsig_self; pcsig_fields} =
+ Csig.mk
+ (sub.typ sub pcsig_self)
+ (List.map (sub.class_type_field sub) pcsig_fields)
end
-module Ast_polyvar : sig
-#1 "ast_polyvar.mli"
-(* Copyright (C) 2017 Authors of BuckleScript
- *
- * 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. *)
-
-(** side effect: it will mark used attributes `bs.as` *)
-val map_row_fields_into_ints:
- Location.t ->
- Parsetree.row_field list ->
- (int * int ) list
-val map_constructor_declarations_into_ints:
- Parsetree.constructor_declaration list ->
- [ `Offset of int | `New of int list ]
+module MT = struct
+ (* Type expressions for the module language *)
-val map_row_fields_into_strings:
- Location.t ->
- Parsetree.row_field list ->
- External_arg_spec.attr
+ let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} =
+ let open Mty in
+ let loc = sub.location sub loc in
+ let attrs = sub.attributes sub attrs in
+ match desc with
+ | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s)
+ | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s)
+ | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg)
+ | Pmty_functor (s, mt1, mt2) ->
+ functor_ ~loc ~attrs (map_loc sub s)
+ (Misc.may_map (sub.module_type sub) mt1)
+ (sub.module_type sub mt2)
+ | Pmty_with (mt, l) ->
+ with_ ~loc ~attrs (sub.module_type sub mt)
+ (List.map (sub.with_constraint sub) l)
+ | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me)
+ | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x)
+ let map_with_constraint sub = function
+ | Pwith_type (lid, d) ->
+ Pwith_type (map_loc sub lid, sub.type_declaration sub d)
+ | Pwith_module (lid, lid2) ->
+ Pwith_module (map_loc sub lid, map_loc sub lid2)
+ | Pwith_typesubst d -> Pwith_typesubst (sub.type_declaration sub d)
+ | Pwith_modsubst (s, lid) ->
+ Pwith_modsubst (map_loc sub s, map_loc sub lid)
-val is_enum :
- Parsetree.row_field list ->
- bool
+ let map_signature_item sub {psig_desc = desc; psig_loc = loc} =
+ let open Sig in
+ let loc = sub.location sub loc in
+ match desc with
+ | Psig_value vd -> value ~loc (sub.value_description sub vd)
+ | Psig_type l -> type_ ~loc (List.map (sub.type_declaration sub) l)
+ | Psig_typext te -> type_extension ~loc (sub.type_extension sub te)
+ | Psig_exception ed -> exception_ ~loc (sub.extension_constructor sub ed)
+ | Psig_module x -> module_ ~loc (sub.module_declaration sub x)
+ | Psig_recmodule l ->
+ rec_module ~loc (List.map (sub.module_declaration sub) l)
+ | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x)
+ | Psig_open x -> open_ ~loc (sub.open_description sub x)
+ | Psig_include x -> include_ ~loc (sub.include_description sub x)
+ | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l)
+ | Psig_class_type l ->
+ class_type ~loc (List.map (sub.class_type_declaration sub) l)
+ | Psig_extension (x, attrs) ->
+ extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs)
+ | Psig_attribute x -> attribute ~loc (sub.attribute sub x)
+end
-val is_enum_polyvar :
- Parsetree.type_declaration ->
- Parsetree.row_field list option
-val is_enum_constructors :
- Parsetree.constructor_declaration list ->
- bool
-end = struct
-#1 "ast_polyvar.ml"
-(* Copyright (C) 2017 Authors of BuckleScript
- *
- * 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 M = struct
+ (* Value expressions for the module language *)
+ let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} =
+ let open Mod in
+ let loc = sub.location sub loc in
+ let attrs = sub.attributes sub attrs in
+ match desc with
+ | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x)
+ | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str)
+ | Pmod_functor (arg, arg_ty, body) ->
+ functor_ ~loc ~attrs (map_loc sub arg)
+ (Misc.may_map (sub.module_type sub) arg_ty)
+ (sub.module_expr sub body)
+ | Pmod_apply (m1, m2) ->
+ apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2)
+ | Pmod_constraint (m, mty) ->
+ constraint_ ~loc ~attrs (sub.module_expr sub m)
+ (sub.module_type sub mty)
+ | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e)
+ | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x)
-let map_row_fields_into_ints ptyp_loc
- (row_fields : Parsetree.row_field list)
- =
- let _, acc
- =
- (List.fold_left
- (fun (i,acc) rtag ->
- match rtag with
- | Parsetree.Rtag (label, attrs, true, [])
- ->
- begin match Ast_attributes.iter_process_bs_int_as attrs with
- | Some i ->
- i + 1,
- ((Ext_pervasives.hash_variant label , i):: acc )
- | None ->
- i + 1 ,
- ((Ext_pervasives.hash_variant label , i):: acc )
- end
- | _ ->
- Bs_syntaxerr.err ptyp_loc Invalid_bs_int_type
- ) (0, []) row_fields) in
- List.rev acc
+ let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} =
+ let open Str in
+ let loc = sub.location sub loc in
+ match desc with
+ | Pstr_eval (x, attrs) ->
+ eval ~loc ~attrs:(sub.attributes sub attrs) (sub.expr sub x)
+ | Pstr_value (r, vbs) ->
+(* XXX *)
+(* value ~loc r (List.map (sub.value_binding sub) vbs) *)
+ value ~loc r
+ ((if r = Recursive then sub.value_bindings_rec else sub.value_bindings)
+ sub vbs)
+(* XXX *)
+ | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd)
+ | Pstr_type l -> type_ ~loc (List.map (sub.type_declaration sub) l)
+ | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te)
+ | Pstr_exception ed -> exception_ ~loc (sub.extension_constructor sub ed)
+ | Pstr_module x -> module_ ~loc (sub.module_binding sub x)
+ | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l)
+ | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x)
+ | Pstr_open x -> open_ ~loc (sub.open_description sub x)
+ | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l)
+ | Pstr_class_type l ->
+ class_type ~loc (List.map (sub.class_type_declaration sub) l)
+ | Pstr_include x -> include_ ~loc (sub.include_declaration sub x)
+ | Pstr_extension (x, attrs) ->
+ extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs)
+ | Pstr_attribute x -> attribute ~loc (sub.attribute sub x)
+end
-(** Note this is okay with enums, for variants,
- the underlying representation may change due to
- unbox
-*)
-let map_constructor_declarations_into_ints
- (row_fields : Parsetree.constructor_declaration list)
- =
- let mark = ref `nothing in
- let _, acc
- =
- (List.fold_left
- (fun (i,acc) (rtag : Parsetree.constructor_declaration) ->
+module E = struct
+ (* Value expressions for the core language *)
- let attrs = rtag.pcd_attributes in
- begin match Ast_attributes.iter_process_bs_int_as attrs with
- | Some j ->
- if j <> i then
- (
- if i = 0 then mark := `offset j
- else mark := `complex
- )
- ;
- (j + 1,
- (j:: acc ) )
- | None ->
- i + 1 ,
- ( i:: acc )
- end
+ let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} =
+ let open Exp in
+ let loc = sub.location sub loc in
+ let attrs = sub.attributes sub attrs in
+ match desc with
+ | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x)
+ | Pexp_constant x -> constant ~loc ~attrs x
+ | Pexp_let (r, vbs, e) ->
+(* XXXX *)
+ (* let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs)
+ (sub.expr sub e) *)
+ let_ ~loc ~attrs r
+ (
+ (if r = Recursive then sub.value_bindings_rec else sub.value_bindings)
+ sub vbs
+ )
+ (sub.expr sub e)
+(* XXXX *)
+ | Pexp_fun (lab, def, p, e) ->
+ fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p)
+ (sub.expr sub e)
+ | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel)
+ | Pexp_apply (e, l) ->
+ apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l)
+ | Pexp_match (e, pel) ->
+ match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
+ | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
+ | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el)
+ | Pexp_construct (lid, arg) ->
+ construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg)
+ | Pexp_variant (lab, eo) ->
+ variant ~loc ~attrs lab (map_opt (sub.expr sub) eo)
+ | Pexp_record (l, eo) ->
+ record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l)
+ (map_opt (sub.expr sub) eo)
+ | Pexp_field (e, lid) ->
+ field ~loc ~attrs (sub.expr sub e) (map_loc sub lid)
+ | Pexp_setfield (e1, lid, e2) ->
+ setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid)
+ (sub.expr sub e2)
+ | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el)
+ | Pexp_ifthenelse (e1, e2, e3) ->
+ ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
+ (map_opt (sub.expr sub) e3)
+ | Pexp_sequence (e1, e2) ->
+ sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
+ | Pexp_while (e1, e2) ->
+ while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
+ | Pexp_for (p, e1, e2, d, e3) ->
+ for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d
+ (sub.expr sub e3)
+ | Pexp_coerce (e, t1, t2) ->
+ coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1)
+ (sub.typ sub t2)
+ | Pexp_constraint (e, t) ->
+ constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t)
+ | Pexp_send (e, s) -> send ~loc ~attrs (sub.expr sub e) s
+ | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid)
+ | Pexp_setinstvar (s, e) ->
+ setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e)
+ | Pexp_override sel ->
+ override ~loc ~attrs
+ (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel)
+ | Pexp_letmodule (s, me, e) ->
+ letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me)
+ (sub.expr sub e)
+ | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e)
+ | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e)
+ | Pexp_poly (e, t) ->
+ poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t)
+ | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls)
+ | Pexp_newtype (s, e) -> newtype ~loc ~attrs s (sub.expr sub e)
+ | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me)
+ | Pexp_open (ovf, lid, e) ->
+ open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e)
+ | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x)
+end
- ) (0, []) row_fields) in
- match !mark with
- | `nothing -> `Offset 0
- | `offset j -> `Offset j
- | `complex -> `New (List.rev acc)
+module P = struct
+ (* Patterns *)
-(** It also check in-consistency of cases like
- {[ [`a | `c of int ] ]}
-*)
-let map_row_fields_into_strings ptyp_loc
- (row_fields : Parsetree.row_field list) =
- let case, result =
- (Ext_list.fold_right (fun tag (nullary, acc) ->
- match nullary, tag with
- | (`Nothing | `Null),
- Parsetree.Rtag (label, attrs, true, [])
- ->
- begin match Ast_attributes.iter_process_bs_string_as attrs with
- | Some name ->
- `Null, ((Ext_pervasives.hash_variant label, name) :: acc )
+ let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} =
+ let open Pat in
+ let loc = sub.location sub loc in
+ let attrs = sub.attributes sub attrs in
+ match desc with
+ | Ppat_any -> any ~loc ~attrs ()
+ | Ppat_var s -> var ~loc ~attrs (map_loc sub s)
+ | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s)
+ | Ppat_constant c -> constant ~loc ~attrs c
+ | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2
+ | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl)
+ | Ppat_construct (l, p) ->
+ construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p)
+ | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p)
+ | Ppat_record (lpl, cf) ->
+ record ~loc ~attrs
+ (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf
+ | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl)
+ | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2)
+ | Ppat_constraint (p, t) ->
+ constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t)
+ | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s)
+ | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p)
+ | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s)
+ | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p)
+ | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x)
+end
- | None ->
- `Null, ((Ext_pervasives.hash_variant label, label) :: acc )
- end
- | (`Nothing | `NonNull), Parsetree.Rtag(label, attrs, false, ([ _ ]))
- ->
- begin match Ast_attributes.iter_process_bs_string_as attrs with
- | Some name ->
- `NonNull, ((Ext_pervasives.hash_variant label, name) :: acc)
- | None ->
- `NonNull, ((Ext_pervasives.hash_variant label, label) :: acc)
- end
- | _ -> Bs_syntaxerr.err ptyp_loc Invalid_bs_string_type
+module CE = struct
+ (* Value expressions for the class language *)
- ) row_fields (`Nothing, [])) in
- (match case with
- | `Nothing -> Bs_syntaxerr.err ptyp_loc Invalid_bs_string_type
- | `Null -> External_arg_spec.NullString result
- | `NonNull -> NonNullString result)
+ let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} =
+ let open Cl in
+ let loc = sub.location sub loc in
+ let attrs = sub.attributes sub attrs in
+ match desc with
+ | Pcl_constr (lid, tys) ->
+ constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys)
+ | Pcl_structure s ->
+ structure ~loc ~attrs (sub.class_structure sub s)
+ | Pcl_fun (lab, e, p, ce) ->
+ fun_ ~loc ~attrs lab
+ (map_opt (sub.expr sub) e)
+ (sub.pat sub p)
+ (sub.class_expr sub ce)
+ | Pcl_apply (ce, l) ->
+ apply ~loc ~attrs (sub.class_expr sub ce)
+ (List.map (map_snd (sub.expr sub)) l)
+ | Pcl_let (r, vbs, ce) ->
+(* XXXX *)
+ (* let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs)
+ (sub.class_expr sub ce) *)
+ let_ ~loc ~attrs r
+ ((if r = Recursive then sub.value_bindings_rec else sub.value_bindings)
+ sub vbs)
+ (sub.class_expr sub ce)
+(* XXXX *)
+ | Pcl_constraint (ce, ct) ->
+ constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct)
+ | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x)
+ let map_kind sub = function
+ | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e)
+ | Cfk_virtual t -> Cfk_virtual (sub.typ sub t)
-let is_enum row_fields =
- List.for_all (fun (x : Parsetree.row_field) ->
- match x with
- | Rtag(_label,_attrs,true, []) -> true
- | _ -> false
- ) row_fields
+ let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} =
+ let open Cf in
+ let loc = sub.location sub loc in
+ let attrs = sub.attributes sub attrs in
+ match desc with
+ | Pcf_inherit (o, ce, s) -> inherit_ ~loc ~attrs o (sub.class_expr sub ce) s
+ | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k)
+ | Pcf_method (s, p, k) ->
+ method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k)
+ | Pcf_constraint (t1, t2) ->
+ constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2)
+ | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e)
+ | Pcf_attribute x -> attribute ~loc (sub.attribute sub x)
+ | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x)
+ let map_structure sub {pcstr_self; pcstr_fields} =
+ {
+ pcstr_self = sub.pat sub pcstr_self;
+ pcstr_fields = List.map (sub.class_field sub) pcstr_fields;
+ }
-let is_enum_polyvar (ty : Parsetree.type_declaration) =
- match ty.ptype_manifest with
- | Some {ptyp_desc = Ptyp_variant(row_fields,Closed,None)}
- when is_enum row_fields ->
- Some row_fields
- | _ -> None
+ let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr;
+ pci_loc; pci_attributes} =
+ Ci.mk
+ ~virt:pci_virt
+ ~params:(List.map (map_fst (sub.typ sub)) pl)
+ (map_loc sub pci_name)
+ (f pci_expr)
+ ~loc:(sub.location sub pci_loc)
+ ~attrs:(sub.attributes sub pci_attributes)
+end
-let is_enum_constructors
- (constructors : Parsetree.constructor_declaration list) =
- List.for_all
- (fun (x : Parsetree.constructor_declaration) ->
- match x with
- | {pcd_args = []} -> true
- | _ -> false
- )
- constructors
+(* Now, a generic AST mapper, to be extended to cover all kinds and
+ cases of the OCaml grammar. The default behavior of the mapper is
+ the identity. *)
+
+let default_mapper =
+ {
+ structure = (fun this l -> List.map (this.structure_item this) l);
+ structure_item = M.map_structure_item;
+ module_expr = M.map;
+ signature = (fun this l -> List.map (this.signature_item this) l);
+ signature_item = MT.map_signature_item;
+ module_type = MT.map;
+ with_constraint = MT.map_with_constraint;
+ class_declaration =
+ (fun this -> CE.class_infos this (this.class_expr this));
+ class_expr = CE.map;
+ class_field = CE.map_field;
+ class_structure = CE.map_structure;
+ class_type = CT.map;
+ class_type_field = CT.map_field;
+ class_signature = CT.map_signature;
+ class_type_declaration =
+ (fun this -> CE.class_infos this (this.class_type this));
+ class_description =
+ (fun this -> CE.class_infos this (this.class_type this));
+ type_declaration = T.map_type_declaration;
+ type_kind = T.map_type_kind;
+ typ = T.map;
+ type_extension = T.map_type_extension;
+ extension_constructor = T.map_extension_constructor;
+ value_description =
+ (fun this {pval_name; pval_type; pval_prim; pval_loc;
+ pval_attributes} ->
+ Val.mk
+ (map_loc this pval_name)
+ (this.typ this pval_type)
+ ~attrs:(this.attributes this pval_attributes)
+ ~loc:(this.location this pval_loc)
+ ~prim:pval_prim
+ );
+
+ pat = P.map;
+ expr = E.map;
+
+ module_declaration =
+ (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} ->
+ Md.mk
+ (map_loc this pmd_name)
+ (this.module_type this pmd_type)
+ ~attrs:(this.attributes this pmd_attributes)
+ ~loc:(this.location this pmd_loc)
+ );
+
+ module_type_declaration =
+ (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} ->
+ Mtd.mk
+ (map_loc this pmtd_name)
+ ?typ:(map_opt (this.module_type this) pmtd_type)
+ ~attrs:(this.attributes this pmtd_attributes)
+ ~loc:(this.location this pmtd_loc)
+ );
+
+ module_binding =
+ (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} ->
+ Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr)
+ ~attrs:(this.attributes this pmb_attributes)
+ ~loc:(this.location this pmb_loc)
+ );
+
+
+ open_description =
+ (fun this {popen_lid; popen_override; popen_attributes; popen_loc} ->
+ Opn.mk (map_loc this popen_lid)
+ ~override:popen_override
+ ~loc:(this.location this popen_loc)
+ ~attrs:(this.attributes this popen_attributes)
+ );
+
+
+ include_description =
+ (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
+ Incl.mk (this.module_type this pincl_mod)
+ ~loc:(this.location this pincl_loc)
+ ~attrs:(this.attributes this pincl_attributes)
+ );
+
+ include_declaration =
+ (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
+ Incl.mk (this.module_expr this pincl_mod)
+ ~loc:(this.location this pincl_loc)
+ ~attrs:(this.attributes this pincl_attributes)
+ );
+
+ value_bindings = (fun this vbs ->
+ match vbs with
+ | [vb] -> [ this.value_binding this vb ]
+ | _ -> List.map (this.value_binding this) vbs
+ );
+ value_bindings_rec = (fun this vbs ->
+ match vbs with
+ | [vb] -> [ this.value_binding this vb ]
+ | _ -> List.map (this.value_binding this) vbs
+ );
+ value_binding =
+ (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} ->
+ Vb.mk
+ (this.pat this pvb_pat)
+ (this.expr this pvb_expr)
+ ~loc:(this.location this pvb_loc)
+ ~attrs:(this.attributes this pvb_attributes)
+ );
+
+
+ constructor_declaration =
+ (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} ->
+ Type.constructor
+ (map_loc this pcd_name)
+ ~args:(List.map (this.typ this) pcd_args)
+ ?res:(map_opt (this.typ this) pcd_res)
+ ~loc:(this.location this pcd_loc)
+ ~attrs:(this.attributes this pcd_attributes)
+ );
+
+ label_declaration =
+ (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} ->
+ Type.field
+ (map_loc this pld_name)
+ (this.typ this pld_type)
+ ~mut:pld_mutable
+ ~loc:(this.location this pld_loc)
+ ~attrs:(this.attributes this pld_attributes)
+ );
+
+ cases = (fun this l -> List.map (this.case this) l);
+ case =
+ (fun this {pc_lhs; pc_guard; pc_rhs} ->
+ {
+ pc_lhs = this.pat this pc_lhs;
+ pc_guard = map_opt (this.expr this) pc_guard;
+ pc_rhs = this.expr this pc_rhs;
+ }
+ );
+
+
+
+ location = (fun this l -> l);
+
+ extension = (fun this (s, e) -> (map_loc this s, this.payload this e));
+ attribute = (fun this (s, e) -> (map_loc this s, this.payload this e));
+ attributes = (fun this l -> List.map (this.attribute this) l);
+ payload =
+ (fun this -> function
+ | PStr x -> PStr (this.structure this x)
+ | PTyp x -> PTyp (this.typ this x)
+ | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g)
+ );
+ }
end
-module Ast_derive_js_mapper : sig
-#1 "ast_derive_js_mapper.mli"
+module Ast_polyvar : sig
+#1 "ast_polyvar.mli"
(* Copyright (C) 2017 Authors of BuckleScript
*
* This program is free software: you can redistribute it and/or modify
@@ -106285,11 +106499,35 @@ module Ast_derive_js_mapper : sig
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
+(** side effect: it will mark used attributes `bs.as` *)
+val map_row_fields_into_ints:
+ Location.t ->
+ Parsetree.row_field list ->
+ (int * int ) list
+
+val map_constructor_declarations_into_ints:
+ Parsetree.constructor_declaration list ->
+ [ `Offset of int | `New of int list ]
+val map_row_fields_into_strings:
+ Location.t ->
+ Parsetree.row_field list ->
+ External_arg_spec.attr
-val init : unit -> unit
+
+val is_enum :
+ Parsetree.row_field list ->
+ bool
+
+val is_enum_polyvar :
+ Parsetree.type_declaration ->
+ Parsetree.row_field list option
+
+val is_enum_constructors :
+ Parsetree.constructor_declaration list ->
+ bool
end = struct
-#1 "ast_derive_js_mapper.ml"
+#1 "ast_polyvar.ml"
(* Copyright (C) 2017 Authors of BuckleScript
*
* This program is free software: you can redistribute it and/or modify
@@ -106314,694 +106552,1265 @@ end = struct
* 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 U = Ast_derive_util
-type tdcls = Parsetree.type_declaration list
-
-let js_field (o : Parsetree.expression) m =
- Exp.apply
- (Exp.ident {txt = Lident "##"; loc = o.pexp_loc})
- [
- "",o;
- "", Exp.ident m
- ]
-let const_int i = Exp.constant (Const_int i)
-let const_string s = Exp.constant (Const_string (s,None))
-
-let handle_config (config : Parsetree.expression option) =
- match config with
- | Some config ->
- (match config.pexp_desc with
- | Pexp_record (
- [
- {txt = Lident "newType"},
- {pexp_desc =
- (Pexp_construct
- (
- {txt =
- Lident ("true"
- | "false"
- as x)}, None)
- | Pexp_ident {txt = Lident ("newType" as x)}
- )
- }
- ],None)
- -> not (x = "false")
- | Pexp_ident {txt = Lident ("newType")}
- -> true
- | _ -> U.invalid_config config)
- | None -> false
-let noloc = Location.none
-(* [eraseType] will be instrumented, be careful about the name conflict*)
-let eraseTypeLit = "jsMapperEraseType"
-let eraseTypeExp = Exp.ident {loc = noloc; txt = Lident eraseTypeLit}
-let eraseType x =
- Exp.apply eraseTypeExp ["", x]
-let eraseTypeStr =
- let any = Typ.any () in
- Str.primitive
- (Val.mk ~prim:["%identity"] {loc = noloc; txt = eraseTypeLit}
- (Typ.arrow "" any any)
- )
+let map_row_fields_into_ints ptyp_loc
+ (row_fields : Parsetree.row_field list)
+ =
+ let _, acc
+ =
+ (List.fold_left
+ (fun (i,acc) rtag ->
+ match rtag with
+ | Parsetree.Rtag (label, attrs, true, [])
+ ->
+ begin match Ast_attributes.iter_process_bs_int_as attrs with
+ | Some i ->
+ i + 1,
+ ((Ext_pervasives.hash_variant label , i):: acc )
+ | None ->
+ i + 1 ,
+ ((Ext_pervasives.hash_variant label , i):: acc )
+ end
+ | _ ->
+ Bs_syntaxerr.err ptyp_loc Invalid_bs_int_type
+ ) (0, []) row_fields) in
+ List.rev acc
-let app2 f arg1 arg2 =
- Exp.apply f ["",arg1; "", arg2]
-let app3 f arg1 arg2 arg3 =
- Exp.apply f ["", arg1; "", arg2; "", arg3]
-let (<=~) a b =
- app2 (Exp.ident {loc = noloc; txt = Lident "<="}) a b
-let (-~) a b =
- app2 (Exp.ident {loc = noloc; txt = Ldot(Lident "Pervasives","-")})
- a b
-let (+~) a b =
- app2 (Exp.ident {loc = noloc; txt = Ldot(Lident "Pervasives","+")})
- a b
-let (&&~) a b =
- app2 (Exp.ident {loc = noloc; txt = Ldot(Lident "Pervasives","&&")})
- a b
-let (->~) a b = Typ.arrow "" a b
-let jsMapperRt =
- Longident.Ldot (Lident "Js", "MapperRt")
+(** Note this is okay with enums, for variants,
+ the underlying representation may change due to
+ unbox
+*)
+let map_constructor_declarations_into_ints
+ (row_fields : Parsetree.constructor_declaration list)
+ =
+ let mark = ref `nothing in
+ let _, acc
+ =
+ (List.fold_left
+ (fun (i,acc) (rtag : Parsetree.constructor_declaration) ->
-let search upper polyvar array =
- app3
- (Exp.ident ({loc = noloc;
- txt = Longident.Ldot (jsMapperRt,"binarySearch") })
- )
- upper
- (eraseType polyvar)
- array
+ let attrs = rtag.pcd_attributes in
+ begin match Ast_attributes.iter_process_bs_int_as attrs with
+ | Some j ->
+ if j <> i then
+ (
+ if i = 0 then mark := `offset j
+ else mark := `complex
+ )
+ ;
+ (j + 1,
+ (j:: acc ) )
+ | None ->
+ i + 1 ,
+ ( i:: acc )
+ end
-let revSearch len constantArray exp =
- app3
- (Exp.ident
- {loc= noloc;
- txt = Longident.Ldot (jsMapperRt, "revSearch")})
- len
- constantArray
- exp
+ ) (0, []) row_fields) in
+ match !mark with
+ | `nothing -> `Offset 0
+ | `offset j -> `Offset j
+ | `complex -> `New (List.rev acc)
-let revSearchAssert len constantArray exp =
- app3
- (Exp.ident
- {loc= noloc;
- txt = Longident.Ldot (jsMapperRt, "revSearchAssert")})
- len
- constantArray
- exp
+(** It also check in-consistency of cases like
+ {[ [`a | `c of int ] ]}
+*)
+let map_row_fields_into_strings ptyp_loc
+ (row_fields : Parsetree.row_field list) =
+ let case, result =
+ (Ext_list.fold_right (fun tag (nullary, acc) ->
+ match nullary, tag with
+ | (`Nothing | `Null),
+ Parsetree.Rtag (label, attrs, true, [])
+ ->
+ begin match Ast_attributes.iter_process_bs_string_as attrs with
+ | Some name ->
+ `Null, ((Ext_pervasives.hash_variant label, name) :: acc )
-let toInt exp array =
- app2
- (Exp.ident
- { loc=noloc;
- txt = Longident.Ldot (jsMapperRt, "toInt")})
- (eraseType exp)
- array
-let fromInt len array exp =
- app3
- (Exp.ident
- {loc = noloc;
- txt = Longident.Ldot (jsMapperRt,"fromInt")})
- len
- array
- exp
+ | None ->
+ `Null, ((Ext_pervasives.hash_variant label, label) :: acc )
+ end
+ | (`Nothing | `NonNull), Parsetree.Rtag(label, attrs, false, ([ _ ]))
+ ->
+ begin match Ast_attributes.iter_process_bs_string_as attrs with
+ | Some name ->
+ `NonNull, ((Ext_pervasives.hash_variant label, name) :: acc)
+ | None ->
+ `NonNull, ((Ext_pervasives.hash_variant label, label) :: acc)
+ end
+ | _ -> Bs_syntaxerr.err ptyp_loc Invalid_bs_string_type
-let fromIntAssert len array exp =
- app3
- (Exp.ident
- {loc = noloc;
- txt = Longident.Ldot (jsMapperRt,"fromIntAssert")})
- len
- array
- exp
+ ) row_fields (`Nothing, [])) in
+ (match case with
+ | `Nothing -> Bs_syntaxerr.err ptyp_loc Invalid_bs_string_type
+ | `Null -> External_arg_spec.NullString result
+ | `NonNull -> NonNullString result)
-let assertExp e =
- Exp.extension
- ({Asttypes.loc = noloc; txt = "assert"},
- (PStr
- [Str.eval e ]
- )
+let is_enum row_fields =
+ List.for_all (fun (x : Parsetree.row_field) ->
+ match x with
+ | Rtag(_label,_attrs,true, []) -> true
+ | _ -> false
+ ) row_fields
+
+
+let is_enum_polyvar (ty : Parsetree.type_declaration) =
+ match ty.ptype_manifest with
+ | Some {ptyp_desc = Ptyp_variant(row_fields,Closed,None)}
+ when is_enum row_fields ->
+ Some row_fields
+ | _ -> None
+
+let is_enum_constructors
+ (constructors : Parsetree.constructor_declaration list) =
+ List.for_all
+ (fun (x : Parsetree.constructor_declaration) ->
+ match x with
+ | {pcd_args = []} -> true
+ | _ -> false
)
-let derivingName = "jsConverter"
+ constructors
+end
+module Bs_loc : sig
+#1 "bs_loc.mli"
+(* 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 notApplicable loc =
- Location.prerr_warning
- loc
- (Warnings.Bs_derive_warning ( derivingName ^ " not applicable to this type")) *)
+type t = Location.t = {
+ loc_start : Lexing.position;
+ loc_end : Lexing.position ;
+ loc_ghost : bool
+}
-let init () =
- Ast_derive.register
- derivingName
- (fun ( x : Parsetree.expression option) ->
- let createType = handle_config x in
+val is_ghost : t -> bool
+val merge : t -> t -> t
+val none : t
- {
- structure_gen = (fun (tdcls : tdcls) _ ->
- let handle_tdcl (tdcl: Parsetree.type_declaration) =
- let core_type = U.core_type_of_type_declaration tdcl
- in
- let name = tdcl.ptype_name.txt in
- let toJs = name ^ "ToJs" in
- let fromJs = name ^ "FromJs" in
- let constantArray = "jsMapperConstantArray" in
- let loc = tdcl.ptype_loc in
- let patToJs = {Asttypes.loc; txt = toJs} in
- let patFromJs = {Asttypes.loc; txt = fromJs} in
- let param = "param" in
- let ident_param = {Asttypes.txt = Longident.Lident param; loc} in
- let pat_param = {Asttypes.loc; txt = param} in
- let exp_param = Exp.ident ident_param in
- let newType,newTdcl =
- U.new_type_of_type_declaration tdcl ("abs_" ^ name) in
- let newTypeStr = Str.type_ [newTdcl] in
- let toJsBody body =
- Ast_comb.single_non_rec_value patToJs
- (Exp.fun_ "" None (Pat.constraint_ (Pat.var pat_param) core_type)
- body )
- in
- let (+>) a ty =
- Exp.constraint_ (eraseType a) ty in
- let (+:) a ty =
- eraseType (Exp.constraint_ a ty) in
- let coerceResultToNewType e =
- if createType then
- e +> newType
- else e
- in
- match tdcl.ptype_kind with
- | Ptype_record label_declarations ->
- let exp =
- coerceResultToNewType
- (Exp.extension
- (
- {Asttypes.loc; txt = "bs.obj"},
- (PStr
- [Str.eval
- (Exp.record
- (List.map
- (fun ({pld_name = {loc; txt } } : Parsetree.label_declaration) ->
- let label =
- {Asttypes.loc; txt = Longident.Lident txt } in
- label,Exp.field exp_param label
- ) label_declarations) None)]))) in
- let toJs =
- toJsBody exp
- in
- let obj_exp =
- Exp.record
- (List.map
- (fun ({pld_name = {loc; txt } } : Parsetree.label_declaration) ->
- let label =
- {Asttypes.loc; txt = Longident.Lident txt } in
- label,
- js_field exp_param label
- ) label_declarations) None in
- let fromJs =
- Ast_comb.single_non_rec_value patFromJs
- (Exp.fun_ "" None (Pat.var pat_param)
- (if createType then
- (Exp.let_ Nonrecursive
- [Vb.mk
- (Pat.var pat_param)
- (exp_param +: newType)]
- (Exp.constraint_ obj_exp core_type) )
- else
- (Exp.constraint_ obj_exp core_type) ))
- in
- let rest =
- [
- toJs;
- fromJs
- ] in
- if createType then eraseTypeStr:: newTypeStr :: rest else rest
- | Ptype_abstract ->
- (match Ast_polyvar.is_enum_polyvar tdcl with
- | Some row_fields ->
- let attr =
- Ast_polyvar.map_row_fields_into_strings loc row_fields
- in
- let expConstantArray =
- Exp.ident {loc; txt = Longident.Lident constantArray} in
- begin match attr with
- | NullString result ->
- let result_len = List.length result in
- let exp_len = const_int result_len in
- let v = [
- eraseTypeStr;
- Ast_comb.single_non_rec_value
- {loc; txt = constantArray}
- (Exp.array
- (List.map (fun (i,str) ->
- Exp.tuple
- [
- const_int i;
- const_string str
- ]
- ) (List.sort (fun (a,_) (b,_) -> compare (a:int) b) result)));
- (
- toJsBody
- (coerceResultToNewType
- (search
- exp_len
- exp_param
- expConstantArray
- ))
- );
- Ast_comb.single_non_rec_value
- patFromJs
- (Exp.fun_ "" None
- (Pat.var pat_param)
- (if createType then
- revSearchAssert
- exp_len
- expConstantArray
- (exp_param +: newType)
- +>
- core_type
- else
- revSearch
- exp_len
- expConstantArray
- exp_param
- +>
- Ast_core_type.lift_option_type core_type
- )
- )
- ] in
- if createType then
- newTypeStr :: v
- else v
- | _ -> assert false
- end
- | None ->
- U.notApplicable
- tdcl.Parsetree.ptype_loc
- derivingName;
- []
- )
+end = struct
+#1 "bs_loc.ml"
+(* 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 = Location.t = {
+ loc_start : Lexing.position;
+ loc_end : Lexing.position ;
+ loc_ghost : bool
+}
+
+let is_ghost x = x.loc_ghost
+
+let merge (l: t) (r : t) =
+ if is_ghost l then r
+ else if is_ghost r then l
+ else match l,r with
+ | {loc_start ; }, {loc_end; _} (* TODO: improve*)
+ ->
+ {loc_start ;loc_end; loc_ghost = false}
+
+let none = Location.none
+
+end
+module External_process : sig
+#1 "external_process.mli"
+(* 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. *)
+
+
+
+
+
+(**
+ [handle_attributes_as_string
+ loc pval_name.txt pval_type pval_attributes pval_prim]
+ [pval_name.txt] is the name of identifier
+ [pval_prim] is the name of string literal
+
+ return value is of [pval_type, pval_prims, new_attrs]
+*)
+val handle_attributes_as_string :
+ Bs_loc.t ->
+ string ->
+ Ast_core_type.t ->
+ Ast_attributes.t ->
+ string ->
+ Ast_core_type.t * string list * Ast_attributes.t
+
+
+
+
+(** [pval_prim_of_labels labels]
+ return [pval_prims] for FFI, it is specialized for
+ external object which is used in
+ {[ [%obj { x = 2; y = 1} ] ]}
+*)
+val pval_prim_of_labels : string Asttypes.loc list -> string list
+
+
+
+end = struct
+#1 "external_process.ml"
+(* 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. *)
+
+
+[@@@ocaml.warning "+9"]
+
+
+
+let variant_can_bs_unwrap_fields row_fields =
+ let validity =
+ List.fold_left
+ begin fun st row ->
+ match st, row with
+ | (* we've seen no fields or only valid fields so far *)
+ (`No_fields | `Valid_fields),
+ (* and this field has one constructor arg that we can unwrap to *)
+ Parsetree.Rtag (label, attrs, false, ([ _ ]))
+ ->
+ `Valid_fields
+ | (* otherwise, this field or a previous field was invalid *)
+ _ ->
+ `Invalid_field
+ end
+ `No_fields
+ row_fields
+ in
+ match validity with
+ | `Valid_fields -> true
+ | `No_fields
+ | `Invalid_field -> false
+
+
+(** Given the type of argument, process its [bs.] attribute and new type,
+ The new type is currently used to reconstruct the external type
+ and result type in [@@bs.obj]
+ They are not the same though, for example
+ {[
+ external f : hi:([ `hi | `lo ] [@bs.string]) -> unit -> _ = "" [@@bs.obj]
+ ]}
+ The result type would be [ hi:string ]
+*)
+let get_arg_type ~nolabel optional
+ (ptyp : Ast_core_type.t) :
+ External_arg_spec.attr * Ast_core_type.t =
+ let ptyp = if optional then Ast_core_type.extract_option_type_exn ptyp else ptyp in
+ if Ast_core_type.is_any ptyp then (* (_[@bs.as ])*)
+ if optional then
+ Bs_syntaxerr.err ptyp.ptyp_loc Invalid_underscore_type_in_external
+ else begin
+ let ptyp_attrs =
+ ptyp.Parsetree.ptyp_attributes
+ in
+ let result =
+ Ast_attributes.iter_process_bs_string_or_int_as ptyp_attrs
+ in
+ (* when ppx start dropping attributes
+ we should warn, there is a trade off whether
+ we should warn dropped non bs attribute or not
+ *)
+ Bs_ast_invariant.warn_unused_attributes ptyp_attrs;
+ match result with
+ | None ->
+ Bs_syntaxerr.err ptyp.ptyp_loc Invalid_underscore_type_in_external
+
+ | Some (`Int i) ->
+ Arg_cst(External_arg_spec.cst_int i), Ast_literal.type_int ~loc:ptyp.ptyp_loc ()
+ | Some (`Str i)->
+ Arg_cst (External_arg_spec.cst_string i), Ast_literal.type_string ~loc:ptyp.ptyp_loc ()
+ | Some (`Json_str s) ->
+ Arg_cst (External_arg_spec.cst_json ptyp.ptyp_loc s),
+ Ast_literal.type_string ~loc:ptyp.ptyp_loc ()
+
+ end
+ else (* ([`a|`b] [@bs.string]) *)
+ let ptyp_desc = ptyp.ptyp_desc in
+ match Ast_attributes.process_bs_string_int_unwrap_uncurry ptyp.ptyp_attributes with
+ | (`String, ptyp_attributes)
+ ->
+ begin match ptyp_desc with
+ | Ptyp_variant ( row_fields, Closed, None)
+ ->
+ let attr =
+ Ast_polyvar.map_row_fields_into_strings ptyp.ptyp_loc row_fields in
+ attr,
+ {ptyp with
+ ptyp_attributes
+ }
+ | _ ->
+ Bs_syntaxerr.err ptyp.ptyp_loc Invalid_bs_string_type
+ end
+ | (`Ignore, ptyp_attributes) ->
+ (Ignore, {ptyp with ptyp_attributes})
+ | (`Int , ptyp_attributes) ->
+ begin match ptyp_desc with
+ | Ptyp_variant ( row_fields, Closed, None) ->
+ let int_lists =
+ Ast_polyvar.map_row_fields_into_ints ptyp.ptyp_loc row_fields in
+ Int int_lists ,
+ {ptyp with
+ ptyp_attributes
+ }
+ | _ -> Bs_syntaxerr.err ptyp.ptyp_loc Invalid_bs_int_type
+ end
+ | (`Unwrap, ptyp_attributes) ->
+
+ begin match ptyp_desc with
+ | (Ptyp_variant (row_fields, Closed, _) as ptyp_desc)
+ when variant_can_bs_unwrap_fields row_fields ->
+ Unwrap, {ptyp with ptyp_desc; ptyp_attributes}
+ | _ ->
+ Bs_syntaxerr.err ptyp.ptyp_loc Invalid_bs_unwrap_type
+ end
+ | (`Uncurry opt_arity, ptyp_attributes) ->
+ let real_arity = Ast_core_type.get_uncurry_arity ptyp in
+ (begin match opt_arity, real_arity with
+ | Some arity, `Not_function ->
+ Fn_uncurry_arity arity
+ | None, `Not_function ->
+ Bs_syntaxerr.err ptyp.ptyp_loc Canot_infer_arity_by_syntax
+ | None, `Arity arity ->
+ Fn_uncurry_arity arity
+ | Some arity, `Arity n ->
+ if n <> arity then
+ Bs_syntaxerr.err ptyp.ptyp_loc (Inconsistent_arity (arity,n))
+ else Fn_uncurry_arity arity
+
+ end, {ptyp with ptyp_attributes})
+ | (`Nothing, ptyp_attributes) ->
+ begin match ptyp_desc with
+ | Ptyp_constr ({txt = Lident "bool"; _}, [])
+ ->
+ Bs_warnings.prerr_bs_ffi_warning ptyp.ptyp_loc Unsafe_ffi_bool_type;
+ Nothing
+ | Ptyp_constr ({txt = Lident "unit"; _}, [])
+ -> if nolabel then Extern_unit else Nothing
+ | Ptyp_constr ({txt = Lident "array"; _}, [_])
+ -> Array
+ | Ptyp_variant _ ->
+ Bs_warnings.prerr_bs_ffi_warning ptyp.ptyp_loc Unsafe_poly_variant_type;
+ Nothing
+ | _ ->
+ Nothing
+ end, ptyp
+
+
+
+(**
+ [@@bs.module "react"]
+ [@@bs.module "react"]
+ ---
+ [@@bs.module "@" "react"]
+ [@@bs.module "@" "react"]
+
+ They should have the same module name
+
+ TODO: we should emit an warning if we bind
+ two external files to the same module name
+*)
+type bundle_source =
+ [`Nm_payload of string (* from payload [@@bs.val "xx" ]*)
+ |`Nm_external of string (* from "" in external *)
+ | `Nm_val of string (* from function name *)
+ ]
+
+let string_of_bundle_source (x : bundle_source) =
+ match x with
+ | `Nm_payload x
+ | `Nm_external x
+ | `Nm_val x -> x
+type name_source =
+ [ bundle_source
+ | `Nm_na
+
+ ]
+
+
+
+
+type st =
+ { val_name : name_source;
+ external_module_name : External_ffi_types.external_module_name option;
+ module_as_val : External_ffi_types.external_module_name option;
+ val_send : name_source ;
+ val_send_pipe : Ast_core_type.t option;
+ splice : bool ; (* mutable *)
+ scopes : string list ;
+ set_index : bool; (* mutable *)
+ get_index : bool;
+ new_name : name_source ;
+ call_name : name_source ;
+ set_name : name_source ;
+ get_name : name_source ;
+
+ mk_obj : bool ;
+ return_wrapper : External_ffi_types.return_wrapper ;
+
+ }
+
+let init_st =
+ {
+ val_name = `Nm_na;
+ external_module_name = None ;
+ module_as_val = None;
+ val_send = `Nm_na;
+ val_send_pipe = None;
+ splice = false;
+ scopes = [];
+ set_index = false;
+ get_index = false;
+ new_name = `Nm_na;
+ call_name = `Nm_na;
+ set_name = `Nm_na ;
+ get_name = `Nm_na ;
+ mk_obj = false ;
+ return_wrapper = Return_unset;
+
+ }
+
+
+
+
+
+let process_external_attributes
+ no_arguments
+ (prim_name_or_pval_prim: [< bundle_source ] as 'a)
+ pval_prim
+ (prim_attributes : Ast_attributes.t) : _ * Ast_attributes.t =
+
+ (* shared by `[@@bs.val]`, `[@@bs.send]`,
+ `[@@bs.set]`, `[@@bs.get]` , `[@@bs.new]`
+ `[@@bs.send.pipe]` does not use it
+ *)
+ let name_from_payload_or_prim ~loc (payload : Parsetree.payload) : name_source =
+ match payload with
+ | PStr [] ->
+ (prim_name_or_pval_prim :> name_source)
+ (* It is okay to have [@@bs.val] without payload *)
+ | _ ->
+ begin match Ast_payload.is_single_string payload with
+ | Some (val_name, _) -> `Nm_payload val_name
+ | None ->
+ Location.raise_errorf ~loc "Invalid payload"
+ end
+
+ in
+ List.fold_left
+ (fun (st, attrs)
+ (({txt ; loc}, payload) as attr : Ast_attributes.attr)
+ ->
+ if Ext_string.starts_with txt "bs." then
+ begin match txt with
+ | "bs.val" ->
+ if no_arguments then
+ {st with val_name = name_from_payload_or_prim ~loc payload}
+ else
+ {st with call_name = name_from_payload_or_prim ~loc payload}
+
+ | "bs.module" ->
+ begin match Ast_payload.assert_strings loc payload with
+ | [bundle] ->
+ {st with external_module_name =
+ Some {bundle; module_bind_name = Phint_nothing}}
+ | [bundle;bind_name] ->
+ {st with external_module_name =
+ Some {bundle; module_bind_name = Phint_name bind_name}}
+ | [] ->
+ { st with
+ module_as_val =
+ Some
+ { bundle =
+ string_of_bundle_source
+ (prim_name_or_pval_prim :> bundle_source) ;
+ module_bind_name = Phint_nothing}
+ }
+ | _ ->
+ Bs_syntaxerr.err loc Illegal_attribute
+ end
+ | "bs.scope" ->
+ begin match Ast_payload.assert_strings loc payload with
+ | [] ->
+ Bs_syntaxerr.err loc Illegal_attribute
+ (* We need err on empty scope, so we can tell the difference
+ between unset/set
+ *)
+ | scopes -> { st with scopes = scopes }
+ end
+ | "bs.splice" -> {st with splice = true}
+ | "bs.send" ->
+ { st with val_send = name_from_payload_or_prim ~loc payload}
+ | "bs.send.pipe"
+ ->
+ { st with val_send_pipe = Some (Ast_payload.as_core_type loc payload)}
+ | "bs.set" ->
+ {st with set_name = name_from_payload_or_prim ~loc payload}
+ | "bs.get" -> {st with get_name = name_from_payload_or_prim ~loc payload}
+
+ | "bs.new" -> {st with new_name = name_from_payload_or_prim ~loc payload}
+ | "bs.set_index" -> {st with set_index = true}
+ | "bs.get_index"-> {st with get_index = true}
+ | "bs.obj" -> {st with mk_obj = true}
+ | "bs.return" ->
+ let aux loc txt : External_ffi_types.return_wrapper =
+ begin match txt with
+ | "undefined_to_opt" -> Return_undefined_to_opt
+ | "null_to_opt" -> Return_null_to_opt
+ | "nullable"
+ | "null_undefined_to_opt" -> Return_null_undefined_to_opt
+ | "identity" -> Return_identity
+ | _ ->
+ Bs_syntaxerr.err loc Not_supported_directive_in_bs_return
+ end in
+ let actions =
+ Ast_payload.ident_or_record_as_config loc payload
+ in
+ begin match actions with
+ | [ ({txt; _ },None) ] ->
+ { st with return_wrapper = aux loc txt}
+ | _ ->
+ Bs_syntaxerr.err loc Not_supported_directive_in_bs_return
+ end
+ | _ -> (Location.prerr_warning loc (Bs_unused_attribute txt); st)
+ end, attrs
+ else (st , attr :: attrs)
+ )
+ (init_st, []) prim_attributes
+
+
+let rec has_bs_uncurry (attrs : Ast_attributes.t) =
+ match attrs with
+ | ({txt = "bs.uncurry"; _ }, _) :: attrs ->
+ true
+ | _ :: attrs -> has_bs_uncurry attrs
+ | [] -> false
+
+
+let check_return_wrapper
+ loc (wrapper : External_ffi_types.return_wrapper)
+ result_type =
+ match wrapper with
+ | Return_identity -> wrapper
+ | Return_unset ->
+ if Ast_core_type.is_unit result_type then
+ Return_replaced_with_unit
+ else if Ast_core_type.is_user_bool result_type then
+ Return_to_ocaml_bool
+ else
+ wrapper
+ | Return_undefined_to_opt
+ | Return_null_to_opt
+ | Return_null_undefined_to_opt
+ ->
+ if Ast_core_type.is_user_option result_type then
+ wrapper
+ else
+ Bs_syntaxerr.err loc Expect_opt_in_bs_return_to_opt
+ | Return_replaced_with_unit
+ | Return_to_ocaml_bool ->
+ assert false (* Not going to happen from user input*)
+
+
+
+
+(** Note that the passed [type_annotation] is already processed by visitor pattern before
+*)
+let handle_attributes
+ (loc : Bs_loc.t)
+ (pval_prim : string )
+ (type_annotation : Parsetree.core_type)
+ (prim_attributes : Ast_attributes.t) (prim_name : string)
+ : Ast_core_type.t * string * External_ffi_types.t * Ast_attributes.t =
+ (** sanity check here
+ {[ int -> int -> (int -> int -> int [@bs.uncurry])]}
+ It does not make sense
+ *)
+ if has_bs_uncurry type_annotation.Parsetree.ptyp_attributes then
+ begin
+ Location.raise_errorf
+ ~loc "[@@bs.uncurry] can not be applied to the whole definition"
+ end;
+
+ let prim_name_or_pval_prim =
+ if String.length prim_name = 0 then `Nm_val pval_prim
+ else `Nm_external prim_name (* need check name *)
+ in
+ let result_type, arg_types_ty =
+ Ast_core_type.list_of_arrow type_annotation in
+ if has_bs_uncurry result_type.ptyp_attributes then
+ begin
+ Location.raise_errorf
+ ~loc:result_type.ptyp_loc
+ "[@@bs.uncurry] can not be applied to tailed position"
+ end ;
+ let (st, left_attrs) =
+ process_external_attributes
+ (arg_types_ty = [])
+ prim_name_or_pval_prim pval_prim prim_attributes in
+
+
+ if st.mk_obj then
+ begin match st with
+ | {
+ val_name = `Nm_na;
+ external_module_name = None ;
+ module_as_val = None;
+ val_send = `Nm_na;
+ val_send_pipe = None;
+ splice = false;
+ new_name = `Nm_na;
+ call_name = `Nm_na;
+ set_name = `Nm_na ;
+ get_name = `Nm_na ;
+ get_index = false ;
+ return_wrapper = Return_unset ;
+ set_index = false ;
+ mk_obj = _;
+ scopes = [];
+ (* wrapper does not work with [bs.obj]
+ TODO: better error message *)
+ } ->
+ if String.length prim_name <> 0 then
+ Location.raise_errorf ~loc "[@@bs.obj] expect external names to be empty string";
+ let arg_kinds, new_arg_types_ty, result_types =
+ Ext_list.fold_right
+ (fun (label,ty,attr,loc) ( arg_labels, arg_types, result_types) ->
+ let arg_label = Ast_core_type.label_name label in
+ let new_arg_label, new_arg_types, output_tys =
+ match arg_label with
+ | Empty ->
+ let arg_type, new_ty = get_arg_type ~nolabel:true false ty in
+ begin match arg_type with
+ | Extern_unit ->
+ External_arg_spec.empty_kind arg_type, (label,new_ty,attr,loc)::arg_types, result_types
+ | _ ->
+ Location.raise_errorf ~loc "expect label, optional, or unit here"
+ end
+ | Label name ->
+ let arg_type, new_ty = get_arg_type ~nolabel:false false ty in
+ begin match arg_type with
+ | Ignore ->
+ External_arg_spec.empty_kind arg_type,
+ (label,new_ty,attr,loc)::arg_types, result_types
+ | Arg_cst i ->
+ let s = (Lam_methname.translate ~loc name) in
+ {arg_label = External_arg_spec.label s (Some i);
+ arg_type },
+ arg_types, (* ignored in [arg_types], reserved in [result_types] *)
+ ((name , [], new_ty) :: result_types)
+ | Nothing | Array ->
+ let s = (Lam_methname.translate ~loc name) in
+ {arg_label = External_arg_spec.label s None ; arg_type },
+ (label,new_ty,attr,loc)::arg_types,
+ ((name , [], new_ty) :: result_types)
+ | Int _ ->
+ let s = Lam_methname.translate ~loc name in
+ {arg_label = External_arg_spec.label s None; arg_type},
+ (label,new_ty,attr,loc)::arg_types,
+ ((name, [], Ast_literal.type_int ~loc ()) :: result_types)
+ | NullString _ ->
+ let s = Lam_methname.translate ~loc name in
+ {arg_label = External_arg_spec.label s None; arg_type},
+ (label,new_ty,attr,loc)::arg_types,
+ ((name, [], Ast_literal.type_string ~loc ()) :: result_types)
+ | Fn_uncurry_arity _ ->
+ Location.raise_errorf ~loc
+ "The combination of [@@bs.obj], [@@bs.uncurry] is not supported yet"
+ | Extern_unit -> assert false
+ | NonNullString _
+ ->
+ Location.raise_errorf ~loc
+ "bs.obj label %s does not support such arg type" name
+ | Unwrap ->
+ Location.raise_errorf ~loc
+ "bs.obj label %s does not support [@bs.unwrap] arguments" name
+ end
+ | Optional name ->
+ let arg_type, new_ty_extract = get_arg_type ~nolabel:false true ty in
+ let new_ty = Ast_core_type.lift_option_type new_ty_extract in
+ begin match arg_type with
+ | Ignore ->
+ External_arg_spec.empty_kind arg_type,
+ (label,new_ty,attr,loc)::arg_types, result_types
+
+ | Nothing | Array ->
+ let s = (Lam_methname.translate ~loc name) in
+ {arg_label = External_arg_spec.optional s; arg_type},
+ (label,new_ty,attr,loc)::arg_types,
+ ( (name, [], Ast_comb.to_undefined_type loc new_ty_extract) :: result_types)
+ | Int _ ->
+ let s = Lam_methname.translate ~loc name in
+ {arg_label = External_arg_spec.optional s ; arg_type },
+ (label,new_ty,attr,loc)::arg_types,
+ ((name, [], Ast_comb.to_undefined_type loc @@ Ast_literal.type_int ~loc ()) :: result_types)
+ | NullString _ ->
+ let s = Lam_methname.translate ~loc name in
+ {arg_label = External_arg_spec.optional s ; arg_type },
+ (label,new_ty,attr,loc)::arg_types,
+ ((name, [], Ast_comb.to_undefined_type loc @@ Ast_literal.type_string ~loc ()) :: result_types)
+ | Arg_cst _
+ ->
+ Location.raise_errorf ~loc "bs.as is not supported with optional yet"
+ | Fn_uncurry_arity _ ->
+ Location.raise_errorf ~loc
+ "The combination of [@@bs.obj], [@@bs.uncurry] is not supported yet"
+ | Extern_unit -> assert false
+ | NonNullString _
+ ->
+ Location.raise_errorf ~loc
+ "bs.obj label %s does not support such arg type" name
+ | Unwrap ->
+ Location.raise_errorf ~loc
+ "bs.obj label %s does not support [@bs.unwrap] arguments" name
+ end
+ in
+ (
+ new_arg_label::arg_labels,
+ new_arg_types,
+ output_tys)) arg_types_ty
+ ( [], [], []) in
+
+ let result =
+ if Ast_core_type.is_any result_type then
+ Ast_core_type.make_obj ~loc result_types
+ else
+ snd @@ get_arg_type ~nolabel:true false result_type (* result type can not be labeled *)
+
+ in
+ begin
+ (
+ Ext_list.fold_right (fun (label,ty,attrs,loc) acc ->
+ Ast_helper.Typ.arrow ~loc ~attrs label ty acc
+ ) new_arg_types_ty result
+ ) ,
+ prim_name,
+ Ffi_obj_create arg_kinds,
+ left_attrs
+ end
+
+ | _ -> Location.raise_errorf ~loc "Attribute found that conflicts with [@@bs.obj]"
+
+ end
+
+ else
+ let splice = st.splice in
+ let arg_type_specs, new_arg_types_ty, arg_type_specs_length =
+ Ext_list.fold_right
+ (fun (label,ty,attr,loc) (arg_type_specs, arg_types, i) ->
+ let arg_label = Ast_core_type.label_name label in
+ let arg_label, arg_type, new_arg_types =
+ match arg_label with
+ | Optional s ->
+
+ let arg_type , new_ty = get_arg_type ~nolabel:false true ty in
+ begin match arg_type with
+ | NonNullString _ ->
+ (* ?x:([`x of int ] [@bs.string]) does not make sense *)
+ Location.raise_errorf
+ ~loc
+ "[@@bs.string] does not work with optional when it has arities in label %s" label
+ | _ ->
+ External_arg_spec.optional s, arg_type,
+ ((label, Ast_core_type.lift_option_type new_ty , attr,loc) :: arg_types) end
+ | Label s ->
+ begin match get_arg_type ~nolabel:false false ty with
+ | (Arg_cst ( i) as arg_type), new_ty ->
+ External_arg_spec.label s (Some i), arg_type, arg_types
+ | arg_type, new_ty ->
+ External_arg_spec.label s None, arg_type, (label, new_ty,attr,loc) :: arg_types
+ end
+ | Empty ->
+ begin match get_arg_type ~nolabel:true false ty with
+ | (Arg_cst ( i) as arg_type), new_ty ->
+ External_arg_spec.empty_lit i , arg_type, arg_types
+ | arg_type, new_ty ->
+ External_arg_spec.empty_label, arg_type, (label, new_ty,attr,loc) :: arg_types
+ end
+ in
+ (if i = 0 && splice then
+ match arg_type with
+ | Array -> ()
+ | _ -> Location.raise_errorf ~loc "[@@@@bs.splice] expect the last type to be an array");
+ ({ External_arg_spec.arg_label ;
+ arg_type
+ } :: arg_type_specs,
+ new_arg_types,
+ if arg_type = Ignore then i
+ else i + 1
+ )
+ ) arg_types_ty
+ (match st with
+ | {val_send_pipe = Some obj; _ } ->
+ let arg_type, new_ty = get_arg_type ~nolabel:true false obj in
+ begin match arg_type with
+ | Arg_cst _ ->
+ Location.raise_errorf ~loc:obj.ptyp_loc "[@bs.as] is not supported in bs.send type "
+ | _ ->
+ (* more error checking *)
+ [External_arg_spec.empty_kind arg_type]
+ ,
+ ["", new_ty, [], obj.ptyp_loc]
+ ,0
+ end
+
+ | {val_send_pipe = None ; _ } -> [],[], 0) in
+
+ let ffi : External_ffi_types.attr = match st with
+ | {set_index = true;
+
+ val_name = `Nm_na;
+ external_module_name = None ;
+ module_as_val = None;
+ val_send = `Nm_na;
+ val_send_pipe = None;
+ splice = false;
+ scopes ;
+ get_index = false;
+ new_name = `Nm_na;
+ call_name = `Nm_na;
+ set_name = `Nm_na ;
+ get_name = `Nm_na ;
+
+ return_wrapper = _;
+ mk_obj = _ ;
+
+ }
+ ->
+ if String.length prim_name <> 0 then
+ Location.raise_errorf ~loc "[@@bs.set_index] expect external names to be empty string";
+ if arg_type_specs_length = 3 then
+ Js_set_index {js_set_index_scopes = scopes}
+ else
+ Location.raise_errorf ~loc "Ill defined attribute [@@bs.set_index](arity of 3)"
+
+ | {set_index = true; _}
+ ->
+ Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.set_index]")
- | Ptype_variant ctors ->
- if Ast_polyvar.is_enum_constructors ctors then
- let xs = Ast_polyvar.map_constructor_declarations_into_ints ctors in
- match xs with
- | `New xs ->
- let constantArrayExp = Exp.ident {loc; txt = Lident constantArray} in
- let exp_len = const_int (List.length ctors) in
- let v = [
- eraseTypeStr;
- Ast_comb.single_non_rec_value
- {loc; txt = constantArray}
- (Exp.array (List.map (fun i -> const_int i) xs ))
- ;
- toJsBody
- (
- coerceResultToNewType @@
- toInt
- exp_param
- constantArrayExp
- )
- ;
- Ast_comb.single_non_rec_value
- patFromJs
- (Exp.fun_ "" None
- (Pat.var pat_param)
- (
- if createType then
- fromIntAssert
- exp_len
- constantArrayExp
- (exp_param +: newType)
- +>
- core_type
- else
- fromInt
- exp_len
- constantArrayExp
- exp_param
- +>
- Ast_core_type.lift_option_type core_type
- )
- )
- ] in
- if createType then newTypeStr :: v else v
- | `Offset offset ->
- let v =
- [ eraseTypeStr;
- toJsBody (
- coerceResultToNewType
- (eraseType exp_param +~ const_int offset)
- )
- ;
- let len = List.length ctors in
- let range_low = const_int (offset + 0) in
- let range_upper = const_int (offset + len - 1) in
+ | {get_index = true;
- Ast_comb.single_non_rec_value
- {loc ; txt = fromJs}
- (Exp.fun_ "" None
- (Pat.var pat_param)
- (if createType then
- (Exp.let_ Nonrecursive
- [Vb.mk
- (Pat.var pat_param)
- (exp_param +: newType)
- ]
- (
- Exp.sequence
- (assertExp
- ((exp_param <=~ range_upper) &&~ (range_low <=~ exp_param))
- )
- (exp_param -~ const_int offset))
- )
- +>
- core_type
- else
- (Exp.ifthenelse
- ( (exp_param <=~ range_upper) &&~ (range_low <=~ exp_param))
- (Exp.construct {loc; txt = Lident "Some"}
- ( Some (exp_param -~ const_int offset)))
- (Some (Exp.construct {loc; txt = Lident "None"} None)))
- +>
- Ast_core_type.lift_option_type core_type
- )
- )
- ] in
- if createType then newTypeStr :: v else v
- else
- begin
- U.notApplicable
- tdcl.Parsetree.ptype_loc
- derivingName;
- []
- end
- | Ptype_open ->
- U.notApplicable tdcl.Parsetree.ptype_loc
- derivingName;
- [] in
- Ext_list.flat_map handle_tdcl tdcls
- );
- signature_gen =
- (fun (tdcls : tdcls) _ ->
- let handle_tdcl tdcl =
- let core_type = U.core_type_of_type_declaration tdcl
- in
- let name = tdcl.ptype_name.txt in
- let toJs = name ^ "ToJs" in
- let fromJs = name ^ "FromJs" in
- let loc = tdcl.ptype_loc in
- let patToJs = {Asttypes.loc; txt = toJs} in
- let patFromJs = {Asttypes.loc; txt = fromJs} in
- let toJsType result =
- Ast_comb.single_non_rec_val patToJs (Typ.arrow "" core_type result) in
- let newType,newTdcl =
- U.new_type_of_type_declaration tdcl ("abs_" ^ name) in
- let newTypeStr = Sig.type_ [newTdcl] in
- let (+?) v rest = if createType then v :: rest else rest in
- match tdcl.ptype_kind with
- | Ptype_record label_declarations ->
+ val_name = `Nm_na;
+ external_module_name = None ;
+ module_as_val = None;
+ val_send = `Nm_na;
+ val_send_pipe = None;
- let objType flag =
- Ast_comb.to_js_type loc @@
- Typ.object_
- (List.map
- (fun ({pld_name = {loc; txt }; pld_type } : Parsetree.label_declaration) ->
- txt, [], pld_type
- ) label_declarations)
- flag in
- newTypeStr +?
- [
- toJsType (if createType then newType else objType Closed);
- Ast_comb.single_non_rec_val patFromJs
- ( (if createType then newType else objType Open)->~ core_type)
- ]
+ splice = false;
+ scopes ;
+ new_name = `Nm_na;
+ call_name = `Nm_na;
+ set_name = `Nm_na ;
+ get_name = `Nm_na ;
+ set_index = false;
+ mk_obj;
+ return_wrapper ;
+ } ->
+ if String.length prim_name <> 0 then
+ Location.raise_errorf ~loc "[@@bs.get_index] expect external names to be empty string";
+ if arg_type_specs_length = 2 then
+ Js_get_index {js_get_index_scopes = scopes}
+ else Location.raise_errorf ~loc
+ "Ill defined attribute [@@bs.get_index] (arity expected 2 : while %d)" arg_type_specs_length
- | Ptype_abstract ->
- (match Ast_polyvar.is_enum_polyvar tdcl with
- | Some _ ->
- let ty1 =
- if createType then newType else
- (Ast_literal.type_string ()) in
- let ty2 =
- if createType then core_type
- else Ast_core_type.lift_option_type core_type in
- newTypeStr +?
- [
- toJsType ty1;
- Ast_comb.single_non_rec_val
- patFromJs
- (ty1 ->~ ty2)
- ]
+ | {get_index = true; _}
- | None ->
- U.notApplicable tdcl.Parsetree.ptype_loc
- derivingName;
- [])
+ ->
+ Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.get_index]")
- | Ptype_variant ctors
- ->
- if Ast_polyvar.is_enum_constructors ctors then
- let ty1 =
- if createType then newType
- else Ast_literal.type_int() in
- let ty2 =
- if createType then core_type
- else Ast_core_type.lift_option_type core_type in
- newTypeStr +?
- [
- toJsType ty1;
- Ast_comb.single_non_rec_val
- patFromJs
- (ty1 ->~ ty2)
- ]
- else
- begin
- U.notApplicable tdcl.Parsetree.ptype_loc
- derivingName;
- []
- end
- | Ptype_open ->
- U.notApplicable tdcl.Parsetree.ptype_loc
- derivingName;
- [] in
- Ext_list.flat_map handle_tdcl tdcls
- );
- expression_gen = None
- }
- )
-;
+ | {module_as_val = Some external_module_name ;
-end
-module Ast_derive_projector : sig
-#1 "ast_derive_projector.mli"
-(* Copyright (C) 2017 Authors of BuckleScript
- *
- * 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. *)
+ get_index = false;
+ val_name ;
+ new_name ;
+
+ external_module_name = None ;
+ val_send = `Nm_na;
+ val_send_pipe = None;
+ scopes = []; (* module as var does not need scopes *)
+ splice;
+ call_name = `Nm_na;
+ set_name = `Nm_na ;
+ get_name = `Nm_na ;
+ set_index = false;
+ return_wrapper = _;
+ mk_obj = _ ;
+ } ->
+ begin match arg_types_ty, new_name, val_name with
+ | [], `Nm_na, _ -> Js_module_as_var external_module_name
+ | _, `Nm_na, _ -> Js_module_as_fn {splice; external_module_name }
+ | _, #bundle_source, #bundle_source ->
+ Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.module].")
+ | _, (`Nm_val _ | `Nm_external _) , `Nm_na
+ -> Js_module_as_class external_module_name
+ | _, `Nm_payload _ , `Nm_na
+ ->
+ Location.raise_errorf ~loc
+ "Incorrect FFI attribute found: (bs.new should not carry a payload here)"
+ end
+ | {module_as_val = Some x; _}
+ ->
+ Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.module].")
+ | {call_name = (`Nm_val name | `Nm_external name | `Nm_payload name) ;
+ splice;
+ scopes ;
+ external_module_name;
-val init : unit -> unit
+ val_name = `Nm_na ;
+ module_as_val = None;
+ val_send = `Nm_na ;
+ val_send_pipe = None;
-end = struct
-#1 "ast_derive_projector.ml"
-open Ast_helper
+ set_index = false;
+ get_index = false;
+ new_name = `Nm_na;
+ set_name = `Nm_na ;
+ get_name = `Nm_na ;
+ mk_obj = _ ;
+ return_wrapper = _ ;
+ } ->
+ Js_call {splice; name; external_module_name; scopes }
+ | {call_name = #bundle_source ; _ }
+ ->
+ Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.val]")
-let invalid_config (config : Parsetree.expression) =
- Location.raise_errorf ~loc:config.pexp_loc "such configuration is not supported"
+ | {val_name = (`Nm_val name | `Nm_external name | `Nm_payload name);
+ external_module_name;
+
+ call_name = `Nm_na ;
+ module_as_val = None;
+ val_send = `Nm_na ;
+ val_send_pipe = None;
+ set_index = false;
+ get_index = false;
+ new_name = `Nm_na;
+ set_name = `Nm_na ;
+ get_name = `Nm_na;
+ mk_obj = _;
+ return_wrapper = _;
+ splice = false ;
+ scopes ;
+ }
+ ->
+ Js_global { name; external_module_name; scopes}
+ | {val_name = #bundle_source ; _ }
+ ->
+ Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.val]")
+
+ | {splice ;
+ scopes ;
+ external_module_name = (Some _ as external_module_name);
+
+ val_name = `Nm_na ;
+ call_name = `Nm_na ;
+ module_as_val = None;
+ val_send = `Nm_na ;
+ val_send_pipe = None;
+ set_index = false;
+ get_index = false;
+ new_name = `Nm_na;
+ set_name = `Nm_na ;
+ get_name = `Nm_na ;
+ mk_obj = _ ;
+ return_wrapper= _ ;
+ }
+ ->
+ let name = string_of_bundle_source prim_name_or_pval_prim in
+ if arg_type_specs_length = 0 then
+ Js_global { name; external_module_name; scopes}
+ else Js_call {splice; name; external_module_name; scopes}
+ | {val_send = (`Nm_val name | `Nm_external name | `Nm_payload name);
+ splice;
+ scopes;
+ val_send_pipe = None;
+ val_name = `Nm_na ;
+ call_name = `Nm_na ;
+ module_as_val = None;
+ set_index = false;
+ get_index = false;
+ new_name = `Nm_na;
+ set_name = `Nm_na ;
+ get_name = `Nm_na ;
+ external_module_name = None ;
+ mk_obj = _ ;
+ return_wrapper = _ ;
+ } ->
+
+ (* PR #2162 - since when we assemble arguments the first argument in
+ [@@bs.send] is ignored
+ *)
+ begin match arg_type_specs with
+ | [] ->
+ Location.raise_errorf
+ ~loc "Ill defined attribute [@@bs.send] (at least one argument)"
+ | {arg_type = Arg_cst _ ; arg_label = _} :: _
+ ->
+ Location.raise_errorf
+ ~loc "Ill defined attribute [@@bs.send] (first argument can not be const)"
+ | _ :: _ ->
+ Js_send {splice ; name; js_send_scopes = scopes ; pipe = false}
+ end
+
+ | {val_send = #bundle_source; _ }
+ -> Location.raise_errorf ~loc "You used an FFI attribute that can't be used with [@@bs.send]"
+
+ | {val_send_pipe = Some typ;
+ (* splice = (false as splice); *)
+ val_send = `Nm_na;
+ val_name = `Nm_na ;
+ call_name = `Nm_na ;
+ module_as_val = None;
+ set_index = false;
+ get_index = false;
+ new_name = `Nm_na;
+ set_name = `Nm_na ;
+ get_name = `Nm_na ;
+ external_module_name = None ;
+ mk_obj = _;
+ return_wrapper = _;
+ scopes;
+ splice ;
+ } ->
+ (** can be one argument *)
+ Js_send {splice ;
+ name = string_of_bundle_source prim_name_or_pval_prim;
+ js_send_scopes = scopes;
+ pipe = true}
+
+ | {val_send_pipe = Some _ ; _}
+ -> Location.raise_errorf ~loc "conflict attributes found with [@@bs.send.pipe]"
+ | {new_name = (`Nm_val name | `Nm_external name | `Nm_payload name);
+ external_module_name;
-type tdcls = Parsetree.type_declaration list
+ val_name = `Nm_na ;
+ call_name = `Nm_na ;
+ module_as_val = None;
+ set_index = false;
+ get_index = false;
+ val_send = `Nm_na ;
+ val_send_pipe = None;
+ set_name = `Nm_na ;
+ get_name = `Nm_na ;
+ splice ;
+ scopes;
+ mk_obj = _ ;
+ return_wrapper = _ ;
-let derivingName = "accessors"
-let init () =
-
- Ast_derive.register
- derivingName
- (fun (x : Parsetree.expression option) ->
- (match x with
- | Some config -> invalid_config config
- | None -> ());
- {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
- ->
- label_declarations
- |> Ext_list.map (
- 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
- (Exp.fun_ "" None
- (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
- ->
- constructor_declarations
- |> Ext_list.map
- (fun
- ( {pcd_name = {loc ; txt = con_name} ; pcd_args ; pcd_loc }:
- Parsetree.constructor_declaration)
- -> (* TODO: add type annotations *)
- let little_con_name = String.uncapitalize con_name in
- let arity = List.length pcd_args 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)
- core_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 = Longident.Lident (List.hd vars )}
- else
- Exp.tuple (Ext_list.map
- (fun x -> Exp.ident {loc ; txt = Longident.Lident x})
- vars
- ) )) core_type
- in
- Ext_list.fold_right (fun var b ->
- Exp.fun_ "" None (Pat.var {loc ; txt = var}) b
- ) vars exp
+ }
+ -> Js_new {name; external_module_name; splice; scopes}
+ | {new_name = #bundle_source ; _ }
+ ->
+ Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.new]")
- 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 handle_tdcl tdcls
+ | {set_name = (`Nm_val name | `Nm_external name | `Nm_payload name);
- 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
- ->
- label_declarations
- |> Ext_list.map
- (fun
- ({pld_name ;
- pld_type
- } :
- Parsetree.label_declaration) ->
- Ast_comb.single_non_rec_val pld_name (Typ.arrow "" core_type pld_type )
- )
- | Ptype_variant constructor_declarations
- ->
- constructor_declarations
- |>
- Ext_list.map
- (fun ({pcd_name = {loc ; txt = con_name} ; pcd_args ; pcd_loc }:
- Parsetree.constructor_declaration)
- ->
- Ast_comb.single_non_rec_val {loc ; txt = (String.uncapitalize con_name)}
- (Ext_list.fold_right
- (fun x acc -> Typ.arrow "" x acc)
- pcd_args
- core_type))
- | Ptype_open | Ptype_abstract ->
- Ast_derive_util.notApplicable tdcl.ptype_loc derivingName ;
- []
- in
- Ext_list.flat_map handle_tdcl tdcls
- end;
- expression_gen = None
- }
- )
+ val_name = `Nm_na ;
+ call_name = `Nm_na ;
+ module_as_val = None;
+ set_index = false;
+ get_index = false;
+ val_send = `Nm_na ;
+ val_send_pipe = None;
+ new_name = `Nm_na ;
+ get_name = `Nm_na ;
+ external_module_name = None;
+ splice = false;
+ mk_obj = _ ;
+ return_wrapper = _;
+ scopes ;
+ }
+ ->
+ if arg_type_specs_length = 2 then
+ Js_set { js_set_scopes = scopes ; js_set_name = name}
+ else Location.raise_errorf ~loc "Ill defined attribute [@@bs.set] (two args required)"
+ | {set_name = #bundle_source; _}
+ -> Location.raise_errorf ~loc "conflict attributes found with [@@bs.set]"
-end
-module Ast_utf8_string : sig
-#1 "ast_utf8_string.mli"
-(* 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. *)
+ | {get_name = (`Nm_val name | `Nm_external name | `Nm_payload name);
+ val_name = `Nm_na ;
+ call_name = `Nm_na ;
+ module_as_val = None;
+ set_index = false;
+ get_index = false;
+ val_send = `Nm_na ;
+ val_send_pipe = None;
+ new_name = `Nm_na ;
+ set_name = `Nm_na ;
+ external_module_name = None;
+ splice = false ;
+ mk_obj = _;
+ return_wrapper = _;
+ scopes
+ }
+ ->
+ if arg_type_specs_length = 1 then
+ Js_get { js_get_name = name; js_get_scopes = scopes }
+ else
+ Location.raise_errorf ~loc "Ill defined attribute [@@bs.get] (only one argument)"
+ | {get_name = #bundle_source; _}
+ -> Location.raise_errorf ~loc "Attribute found that conflicts with [@@bs.get]"
-type error
+ | {get_name = `Nm_na;
+ val_name = `Nm_na ;
+ call_name = `Nm_na ;
+ module_as_val = None;
+ set_index = false;
+ get_index = false;
+ val_send = `Nm_na ;
+ val_send_pipe = None;
+ new_name = `Nm_na ;
+ set_name = `Nm_na ;
+ external_module_name = None;
+ splice = _ ;
+ scopes = _;
+ mk_obj = _;
+ return_wrapper = _;
+ }
+ -> Location.raise_errorf ~loc "Could not infer which FFI category it belongs to, maybe you forgot [%@%@bs.val]? " in
+ begin
+ External_ffi_types.check_ffi ~loc ffi;
+ (* result type can not be labeled *)
+ (* currently we don't process attributes of
+ return type, in the future we may *)
+ let new_result_type = result_type in
+ (* get_arg_type ~nolabel:true false result_type in *)
+ let return_wrapper : External_ffi_types.return_wrapper =
+ check_return_wrapper loc st.return_wrapper new_result_type
+ in
+ (
+ Ext_list.fold_right (fun (label,ty,attrs,loc) acc ->
+ Ast_helper.Typ.arrow ~loc ~attrs label ty acc
+ ) new_arg_types_ty new_result_type
+ ) ,
-type exn += Error of int (* offset *) * error
+ prim_name,
+ (Ffi_bs (arg_type_specs,return_wrapper , ffi)), left_attrs
+ end
-val pp_error : Format.formatter -> error -> unit
+let handle_attributes_as_string
+ pval_loc
+ pval_prim
+ (typ : Ast_core_type.t) attrs v =
+ let pval_type, prim_name, ffi, processed_attrs =
+ handle_attributes pval_loc pval_prim typ attrs v in
+ pval_type, [prim_name; External_ffi_types.to_string ffi], processed_attrs
-
-(* module Interp : sig *)
-(* val check_and_transform : int -> string -> int -> cxt -> unit *)
-(* val transform_test : string -> segments *)
-(* end *)
-val transform_test : string -> string
-val transform : Location.t -> string -> string
+let pval_prim_of_labels labels =
+ let encoding =
+ let arg_kinds =
+ Ext_list.fold_right
+ (fun {Asttypes.loc ; txt } arg_kinds
+ ->
+ let arg_label = External_arg_spec.label (Lam_methname.translate ~loc txt) None in
+ {External_arg_spec.arg_type = Nothing ;
+ arg_label } :: arg_kinds
+ )
+ labels [] in
+ External_ffi_types.to_string
+ (Ffi_obj_create arg_kinds) in
+ [""; encoding]
-end = struct
-#1 "ast_utf8_string.ml"
+end
+module Ast_util : sig
+#1 "ast_util.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -107027,183 +107836,116 @@ end = struct
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
+type args = (string * Parsetree.expression) list
+type loc = Location.t
+type label_exprs = (Longident.t Asttypes.loc * Parsetree.expression) list
+type 'a cxt = loc -> Bs_ast_mapper.mapper -> 'a
-type error =
- | Invalid_code_point
- | Unterminated_backslash
- | Invalid_escape_code of char
- | Invalid_hex_escape
- | Invalid_unicode_escape
-
-let pp_error fmt err =
- Format.pp_print_string fmt @@ match err with
- | Invalid_code_point -> "Invalid code point"
- | Unterminated_backslash -> "\\ ended unexpectedly"
- | Invalid_escape_code c -> "Invalid escape code: " ^ String.make 1 c
- | Invalid_hex_escape ->
- "Invalid \\x escape"
- | Invalid_unicode_escape -> "Invalid \\u escape"
+(** In general three kinds of ast generation.
+ - convert a curried to type to uncurried
+ - convert a curried fun to uncurried fun
+ - convert a uncuried application to normal
+*)
+type uncurry_expression_gen =
+ (Parsetree.pattern ->
+ Parsetree.expression ->
+ Parsetree.expression_desc) cxt
+type uncurry_type_gen =
+ (string -> (* label for error checking *)
+ Parsetree.core_type ->
+ Parsetree.core_type ->
+ Parsetree.core_type) cxt
+(** TODO: the interface is not reusable, it depends on too much context *)
+(** syntax: {[f arg0 arg1 [@bs]]}*)
+val uncurry_fn_apply :
+ (Parsetree.expression ->
+ args ->
+ Parsetree.expression_desc ) cxt
+(** syntax : {[f## arg0 arg1 ]}*)
+val method_apply :
+ (Parsetree.expression ->
+ string ->
+ args ->
+ Parsetree.expression_desc) cxt
-type exn += Error of int (* offset *) * error
+(** syntax {[f#@ arg0 arg1 ]}*)
+val property_apply :
+ (Parsetree.expression ->
+ string ->
+ args ->
+ Parsetree.expression_desc) cxt
+(**
+ [function] can only take one argument, that is the reason we did not adopt it
+ syntax:
+ {[ fun [@bs] pat pat1-> body ]}
+ [to_uncurry_fn (fun pat -> (fun pat1 -> ... body))]
+*)
+val to_uncurry_fn : uncurry_expression_gen
-let error ~loc error =
- raise (Error (loc, error))
-(** Note the [loc] really should be the utf8-offset, it has nothing to do with our
- escaping mechanism
+(** syntax:
+ {[fun [@bs.this] obj pat pat1 -> body]}
*)
-(* we can not just print new line in ES5
- seems we don't need
- escape "\b" "\f"
- we need escape "\n" "\r" since
- ocaml multiple-line allows [\n]
- visual input while es5 string
- does not*)
+val to_method_callback : uncurry_expression_gen
-let rec check_and_transform (loc : int ) buf s byte_offset s_len =
- if byte_offset = s_len then ()
- else
- let current_char = s.[byte_offset] in
- match Ext_utf8.classify current_char with
- | Single 92 (* '\\' *) ->
- escape_code (loc + 1) buf s (byte_offset+1) s_len
- | Single 34 ->
- Buffer.add_string buf "\\\"";
- check_and_transform (loc + 1) buf s (byte_offset + 1) s_len
- | Single 39 ->
- Buffer.add_string buf "\\'";
- check_and_transform (loc + 1) buf s (byte_offset + 1) s_len
- | Single 10 ->
- Buffer.add_string buf "\\n";
- check_and_transform (loc + 1) buf s (byte_offset + 1) s_len
- | Single 13 ->
- Buffer.add_string buf "\\r";
- check_and_transform (loc + 1) buf s (byte_offset + 1) s_len
- | Single _ ->
- Buffer.add_char buf current_char;
- check_and_transform (loc + 1) buf s (byte_offset + 1) s_len
- | Invalid
- | Cont _ -> error ~loc Invalid_code_point
- | Leading (n,_) ->
- let i' = Ext_utf8.next s ~remaining:n byte_offset in
- if i' < 0 then
- error ~loc Invalid_code_point
- else
- begin
- for k = byte_offset to i' do
- Buffer.add_char buf s.[k];
- done;
- check_and_transform (loc + 1 ) buf s (i' + 1) s_len
- end
-(* we share the same escape sequence with js *)
-and escape_code loc buf s offset s_len =
- if offset >= s_len then
- error ~loc Unterminated_backslash
- else
- Buffer.add_char buf '\\';
- let cur_char = s.[offset] in
- match cur_char with
- | '\\'
- | 'b'
- | 't'
- | 'n'
- | 'v'
- | 'f'
- | 'r'
- | '0'
- | '$'
- ->
- begin
- Buffer.add_char buf cur_char ;
- check_and_transform (loc + 1) buf s (offset + 1) s_len
- end
- | 'u' ->
- begin
- Buffer.add_char buf cur_char;
- unicode (loc + 1) buf s (offset + 1) s_len
- end
- | 'x' -> begin
- Buffer.add_char buf cur_char ;
- two_hex (loc + 1) buf s (offset + 1) s_len
- end
- | _ -> error ~loc (Invalid_escape_code cur_char)
-and two_hex loc buf s offset s_len =
- if offset + 1 >= s_len then
- error ~loc Invalid_hex_escape;
- (*Location.raise_errorf ~loc "\\x need at least two chars";*)
- let a, b = s.[offset], s.[offset + 1] in
- if Ext_char.valid_hex a && Ext_char.valid_hex b then
- begin
- Buffer.add_char buf a ;
- Buffer.add_char buf b ;
- check_and_transform (loc + 2) buf s (offset + 2) s_len
- end
- else
- error ~loc Invalid_hex_escape
-(*Location.raise_errorf ~loc "%c%c is not a valid hex code" a b*)
+(** syntax :
+ {[ int -> int -> int [@bs]]}
+*)
+val to_uncurry_type : uncurry_type_gen
+
-and unicode loc buf s offset s_len =
- if offset + 3 >= s_len then
- error ~loc Invalid_unicode_escape
- (*Location.raise_errorf ~loc "\\u need at least four chars"*)
- ;
- let a0,a1,a2,a3 = s.[offset], s.[offset+1], s.[offset+2], s.[offset+3] in
- if
- Ext_char.valid_hex a0 &&
- Ext_char.valid_hex a1 &&
- Ext_char.valid_hex a2 &&
- Ext_char.valid_hex a3 then
- begin
- Buffer.add_char buf a0;
- Buffer.add_char buf a1;
- Buffer.add_char buf a2;
- Buffer.add_char buf a3;
- check_and_transform (loc + 4) buf s (offset + 4) s_len
- end
- else
- error ~loc Invalid_unicode_escape
-(*Location.raise_errorf ~loc "%c%c%c%c is not a valid unicode point"
- a0 a1 a2 a3 *)
-(* http://www.2ality.com/2015/01/es6-strings.html
- console.log('\uD83D\uDE80'); (* ES6*)
- console.log('\u{1F680}');
-*)
+(** syntax
+ {[ method : int -> itn -> int ]}
+*)
+val to_method_type : uncurry_type_gen
+(** syntax:
+ {[ 'obj -> int -> int [@bs.this] ]}
+*)
+val to_method_callback_type : uncurry_type_gen
+val record_as_js_object :
+ (label_exprs ->
+ Parsetree.expression_desc) cxt
+val js_property :
+ loc ->
+ Parsetree.expression -> string -> Parsetree.expression_desc
+val handle_debugger :
+ loc -> Ast_payload.t -> Parsetree.expression_desc
-let transform_test s =
- let s_len = String.length s in
- let buf = Buffer.create (s_len * 2) in
- check_and_transform 0 buf s 0 s_len;
- Buffer.contents buf
+val handle_raw :
+ ?check_js_regex: bool -> loc -> Ast_payload.t -> Parsetree.expression
-let transform loc s =
- let s_len = String.length s in
- let buf = Buffer.create (s_len * 2) in
- try
- check_and_transform 0 buf s 0 s_len;
- Buffer.contents buf
- with
- Error (offset, error)
- -> Location.raise_errorf ~loc "Offset: %d, %a" offset pp_error error
+val handle_external :
+ loc -> string -> Parsetree.expression
+
+val handle_raw_structure :
+ loc -> Ast_payload.t -> Parsetree.structure_item
+val ocaml_obj_as_js_object :
+ (Parsetree.pattern ->
+ Parsetree.class_field list ->
+ Parsetree.expression_desc) cxt
-end
-module Bs_loc : sig
-#1 "bs_loc.mli"
+ val convertBsErrorFunction :
+
+ (Ast_helper.attrs -> Parsetree.case list -> Parsetree.expression) cxt
+
+end = struct
+#1 "ast_util.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -107228,588 +107970,792 @@ module Bs_loc : sig
* 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 = Location.t = {
- loc_start : Lexing.position;
- loc_end : Lexing.position ;
- loc_ghost : bool
-}
+open Ast_helper
+type 'a cxt = Ast_helper.loc -> Bs_ast_mapper.mapper -> 'a
+type loc = Location.t
+type args = (string * Parsetree.expression) list
+type label_exprs = (Longident.t Asttypes.loc * Parsetree.expression) list
+type uncurry_expression_gen =
+ (Parsetree.pattern ->
+ Parsetree.expression ->
+ Parsetree.expression_desc) cxt
+type uncurry_type_gen =
+ (string ->
+ Parsetree.core_type ->
+ Parsetree.core_type ->
+ Parsetree.core_type) cxt
-val is_ghost : t -> bool
-val merge : t -> t -> t
-val none : t
+let uncurry_type_id =
+ Ast_literal.Lid.js_fn
+let method_id =
+ Ast_literal.Lid.js_meth
-end = struct
-#1 "bs_loc.ml"
-(* 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 method_call_back_id =
+ Ast_literal.Lid.js_meth_callback
+let arity_lit = "Arity_"
-type t = Location.t = {
- loc_start : Lexing.position;
- loc_end : Lexing.position ;
- loc_ghost : bool
-}
+let mk_args loc n tys =
+ Typ.variant ~loc
+ [ Rtag (arity_lit ^ string_of_int n, [], (n = 0), tys)] Closed None
-let is_ghost x = x.loc_ghost
+let generic_lift txt loc args result =
+ let xs =
+ match args with
+ | [ ] -> [mk_args loc 0 [] ; result ]
+ | [ x ] -> [ mk_args loc 1 [x] ; result ]
+ | _ ->
+ [mk_args loc (List.length args ) [Typ.tuple ~loc args] ; result ]
+ in
+ Typ.constr ~loc {txt ; loc} xs
-let merge (l: t) (r : t) =
- if is_ghost l then r
- else if is_ghost r then l
- else match l,r with
- | {loc_start ; }, {loc_end; _} (* TODO: improve*)
- ->
- {loc_start ;loc_end; loc_ghost = false}
+let lift_curry_type loc =
+ generic_lift uncurry_type_id loc
-let none = Location.none
+let lift_method_type loc =
+ generic_lift method_id loc
-end
-module Ast_utf8_string_interp : sig
-#1 "ast_utf8_string_interp.mli"
-(* 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 lift_js_method_callback loc
+ =
+ generic_lift method_call_back_id loc
+(** Note that currently there is no way to consume [Js.meth_callback]
+ so it is fine to encode it with a freedom,
+ but we need make it better for error message.
+ - all are encoded as
+ {[
+ type fn = (`Args_n of _ , 'result ) Js.fn
+ type method = (`Args_n of _, 'result) Js.method
+ type method_callback = (`Args_n of _, 'result) Js.method_callback
+ ]}
+ For [method_callback], the arity is never zero, so both [method]
+ and [fn] requires (unit -> 'a) to encode arity zero
+*)
-type kind =
- | String
- | Var
-type error = private
- | Invalid_code_point
- | Unterminated_backslash
- | Invalid_escape_code of char
- | Invalid_hex_escape
- | Invalid_unicode_escape
- | Unterminated_variable
- | Unmatched_paren
- | Invalid_syntax_of_var of string
-(** Note the position is about code point *)
-type pos = { lnum : int ; offset : int ; byte_bol : int }
+let arrow = Typ.arrow
-type segment = {
- start : pos;
- finish : pos ;
- kind : kind;
- content : string ;
-}
-type segments = segment list
+let js_property loc obj name =
+ Parsetree.Pexp_send
+ ((Exp.apply ~loc
+ (Exp.ident ~loc
+ {loc;
+ txt = Ldot (Ast_literal.Lid.js_unsafe, Literals.unsafe_downgrade)})
+ ["",obj]), name)
+
+(* TODO:
+ have a final checking for property arities
+ [#=],
+*)
+
+
+let generic_apply kind loc
+ (self : Bs_ast_mapper.mapper)
+ (obj : Parsetree.expression)
+ (args : args ) cb =
+ let obj = self.expr self obj in
+ let args =
+ Ext_list.map (fun (label,e) ->
+ if label <> "" then
+ Bs_syntaxerr.err loc Label_in_uncurried_bs_attribute;
+ self.expr self e
+ ) args in
+ let len = List.length args in
+ let arity, fn, args =
+ match args with
+ | [ {pexp_desc =
+ Pexp_construct ({txt = Lident "()"}, None)}]
+ ->
+ 0, cb loc obj, []
+ | _ ->
+ len, cb loc obj, args in
+ if arity < 10 then
+ let txt =
+ match kind with
+ | `Fn | `PropertyFn ->
+ Longident.Ldot (Ast_literal.Lid.js_unsafe,
+ Literals.fn_run ^ string_of_int arity)
+ | `Method ->
+ Longident.Ldot(Ast_literal.Lid.js_unsafe,
+ Literals.method_run ^ string_of_int arity
+ ) in
+ Parsetree.Pexp_apply (Exp.ident {txt ; loc}, ("",fn) :: Ext_list.map (fun x -> "",x) args)
+ else
+ let fn_type, args_type, result_type = Ast_comb.tuple_type_pair ~loc `Run arity in
+ let string_arity = string_of_int arity in
+ let pval_prim, pval_type =
+ match kind with
+ | `Fn | `PropertyFn ->
+ ["#fn_run"; string_arity],
+ arrow ~loc "" (lift_curry_type loc args_type result_type ) fn_type
+ | `Method ->
+ ["#method_run" ; string_arity],
+ arrow ~loc "" (lift_method_type loc args_type result_type) fn_type
+ in
+ Ast_external_mk.local_external loc ~pval_prim ~pval_type
+ (("", fn) :: Ext_list.map (fun x -> "",x) args )
+
+
+let uncurry_fn_apply loc self fn args =
+ generic_apply `Fn loc self fn args (fun _ obj -> obj )
+
+let property_apply loc self obj name (args : args)
+ = generic_apply `PropertyFn loc self obj args
+ (fun loc obj -> Exp.mk ~loc (js_property loc obj name))
+
+let method_apply loc self obj name args =
+ generic_apply `Method loc self obj args
+ (fun loc obj -> Exp.mk ~loc (js_property loc obj name))
+
+let generic_to_uncurry_type kind loc (mapper : Bs_ast_mapper.mapper) label
+ (first_arg : Parsetree.core_type)
+ (typ : Parsetree.core_type) =
+ if label <> "" then
+ Bs_syntaxerr.err loc Label_in_uncurried_bs_attribute;
+
+ let rec aux acc (typ : Parsetree.core_type) =
+ (* in general,
+ we should collect [typ] in [int -> typ] before transformation,
+ however: when attributes [bs] and [bs.this] found in typ,
+ we should stop
+ *)
+ match Ast_attributes.process_attributes_rev typ.ptyp_attributes with
+ | `Nothing, _ ->
+ begin match typ.ptyp_desc with
+ | Ptyp_arrow (label, arg, body)
+ ->
+ if label <> "" then
+ Bs_syntaxerr.err typ.ptyp_loc Label_in_uncurried_bs_attribute;
+ aux (mapper.typ mapper arg :: acc) body
+ | _ -> mapper.typ mapper typ, acc
+ end
+ | _, _ -> mapper.typ mapper typ, acc
+ in
+ let first_arg = mapper.typ mapper first_arg in
+ let result, rev_extra_args = aux [first_arg] typ in
+ let args = List.rev rev_extra_args in
+ let filter_args args =
+ match args with
+ | [{Parsetree.ptyp_desc =
+ (Ptyp_constr ({txt = Lident "unit"}, [])
+ )}]
+ -> []
+ | _ -> args in
+ match kind with
+ | `Fn ->
+ let args = filter_args args in
+ lift_curry_type loc args result
+ | `Method ->
+ let args = filter_args args in
+ lift_method_type loc args result
+
+ | `Method_callback
+ -> lift_js_method_callback loc args result
-type cxt = {
- mutable segment_start : pos ;
- buf : Buffer.t ;
- s_len : int ;
- mutable segments : segments;
- mutable pos_bol : int; (* record the abs position of current beginning line *)
- mutable byte_bol : int ;
- mutable pos_lnum : int ; (* record the line number *)
-}
-type exn += Error of pos * pos * error
+let to_uncurry_type =
+ generic_to_uncurry_type `Fn
+let to_method_type =
+ generic_to_uncurry_type `Method
+let to_method_callback_type =
+ generic_to_uncurry_type `Method_callback
-val empty_segment : segment -> bool
+let generic_to_uncurry_exp kind loc (self : Bs_ast_mapper.mapper) pat body
+ =
+ let rec aux acc (body : Parsetree.expression) =
+ match Ast_attributes.process_attributes_rev body.pexp_attributes with
+ | `Nothing, _ ->
+ begin match body.pexp_desc with
+ | Pexp_fun (label,_, arg, body)
+ ->
+ if label <> "" then
+ Bs_syntaxerr.err loc Label_in_uncurried_bs_attribute;
+ aux (self.pat self arg :: acc) body
+ | _ -> self.expr self body, acc
+ end
+ | _, _ -> self.expr self body, acc
+ in
+ let first_arg = self.pat self pat in
+ let () =
+ match kind with
+ | `Method_callback ->
+ if not @@ Ast_pat.is_single_variable_pattern_conservative first_arg then
+ Bs_syntaxerr.err first_arg.ppat_loc Bs_this_simple_pattern
+ | _ -> ()
+ in
-val transform_test : string -> segment list
-val transform_interp : Location.t -> string -> Parsetree.expression
+ let result, rev_extra_args = aux [first_arg] body in
+ let body =
+ List.fold_left (fun e p -> Ast_comb.fun_no_label ~loc p e )
+ result rev_extra_args in
+ let len = List.length rev_extra_args in
+ let arity =
+ match kind with
+ | `Fn ->
+ begin match rev_extra_args with
+ | [ p]
+ ->
+ Ast_pat.is_unit_cont ~yes:0 ~no:len p
-end = struct
-#1 "ast_utf8_string_interp.ml"
-(* 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. *)
+ | _ -> len
+ end
+ | `Method_callback -> len in
+ if arity < 10 then
+ let txt =
+ match kind with
+ | `Fn ->
+ Longident.Ldot ( Ast_literal.Lid.js_unsafe, Literals.fn_mk ^ string_of_int arity)
+ | `Method_callback ->
+ Longident.Ldot (Ast_literal.Lid.js_unsafe, Literals.fn_method ^ string_of_int arity) in
+ Parsetree.Pexp_apply (Exp.ident {txt;loc} , ["",body])
-type error =
- | Invalid_code_point
- | Unterminated_backslash
- | Invalid_escape_code of char
- | Invalid_hex_escape
- | Invalid_unicode_escape
- | Unterminated_variable
- | Unmatched_paren
- | Invalid_syntax_of_var of string
-type kind =
- | String
- | Var
+ else
+ let pval_prim =
+ [ (match kind with
+ | `Fn -> "#fn_mk"
+ | `Method_callback -> "#fn_method");
+ string_of_int arity] in
+ let fn_type , args_type, result_type = Ast_comb.tuple_type_pair ~loc `Make arity in
+ let pval_type = arrow ~loc "" fn_type (
+ match kind with
+ | `Fn ->
+ lift_curry_type loc args_type result_type
+ | `Method_callback ->
+ lift_js_method_callback loc args_type result_type
+ ) in
+ Ast_external_mk.local_extern_cont loc ~pval_prim ~pval_type
+ (fun prim -> Exp.apply ~loc prim ["", body])
+let to_uncurry_fn =
+ generic_to_uncurry_exp `Fn
+let to_method_callback =
+ generic_to_uncurry_exp `Method_callback
-(** Note the position is about code point *)
-type pos = {
- lnum : int ;
- offset : int ;
- byte_bol : int (* Note it actually needs to be in sync with OCaml's lexing semantics *)
-}
+let handle_debugger loc payload =
+ if Ast_payload.as_empty_structure payload then
+ Parsetree.Pexp_apply
+ (Exp.ident {txt = Ldot(Ast_literal.Lid.js_unsafe, Literals.debugger ); loc},
+ ["", Ast_literal.val_unit ~loc ()])
+ else Location.raise_errorf ~loc "bs.raw can only be applied to a string"
-type segment = {
- start : pos;
- finish : pos ;
- kind : kind;
- content : string ;
-}
-type segments = segment list
+let handle_raw ?(check_js_regex = false) loc payload =
+ begin match Ast_payload.as_string_exp ~check_js_regex payload with
+ | Not_String_Lteral ->
+ Location.raise_errorf ~loc
+ "bs.raw can only be applied to a string"
+ | Ast_payload.JS_Regex_Check_Failed ->
+ Location.raise_errorf ~loc "this is an invalid js regex"
+ | Correct exp ->
+ let pexp_desc =
+ Parsetree.Pexp_apply (
+ Exp.ident {loc;
+ txt =
+ Ldot (Ast_literal.Lid.js_unsafe,
+ Literals.raw_expr)},
+ ["",exp]
+ )
+ in
+ { exp with pexp_desc }
+ end
+let handle_external loc x =
+ let raw_exp : Ast_exp.t =
+ Ast_helper.Exp.apply
+ (Exp.ident ~loc
+ {loc; txt = Ldot (Ast_literal.Lid.js_unsafe,
+ Literals.raw_expr)})
+ ~loc
+ [Ext_string.empty,
+ Exp.constant ~loc (Const_string (x,Some Ext_string.empty))] in
+ let empty =
+ Exp.ident ~loc
+ {txt = Ldot (Ldot(Lident"Js", "Undefined"), "empty");loc}
+ in
+ let undefined_typeof =
+ Exp.ident {loc ; txt = Ldot(Lident "Js","undefinedToOption")} in
+ let typeof =
+ Exp.ident {loc ; txt = Ldot(Lident "Js","typeof")} in
-type cxt = {
- mutable segment_start : pos ;
- buf : Buffer.t ;
- s_len : int ;
- mutable segments : segments;
- mutable pos_bol : int; (* record the abs position of current beginning line *)
- mutable byte_bol : int ;
- mutable pos_lnum : int ; (* record the line number *)
-}
+ Exp.apply ~loc undefined_typeof [
+ Ext_string.empty,
+ Exp.ifthenelse ~loc
+ (Exp.apply ~loc
+ (Exp.ident ~loc {loc ; txt = Ldot (Lident "Pervasives", "=")} )
+ [
+ Ext_string.empty,
+ (Exp.apply ~loc typeof [Ext_string.empty,raw_exp]);
+ Ext_string.empty,
+ Exp.constant ~loc (Const_string ("undefined",None))
+ ])
+ (empty)
+ (Some raw_exp)
+ ]
-type exn += Error of pos * pos * error
+let handle_raw_structure loc payload =
+ begin match Ast_payload.as_string_exp payload with
+ | Correct exp
+ ->
+ let pexp_desc =
+ Parsetree.Pexp_apply(
+ Exp.ident {txt = Ldot (Ast_literal.Lid.js_unsafe, Literals.raw_stmt); loc},
+ ["",exp]) in
+ Ast_helper.Str.eval
+ { exp with pexp_desc }
-let pp_error fmt err =
- Format.pp_print_string fmt @@ match err with
- | Invalid_code_point -> "Invalid code point"
- | Unterminated_backslash -> "\\ ended unexpectedly"
- | Invalid_escape_code c -> "Invalid escape code: " ^ String.make 1 c
- | Invalid_hex_escape ->
- "Invalid \\x escape"
- | Invalid_unicode_escape -> "Invalid \\u escape"
- | Unterminated_variable -> "$ unterminated"
- | Unmatched_paren -> "Unmatched paren"
- | Invalid_syntax_of_var s -> "`" ^s ^ "' is not a valid syntax of interpolated identifer"
-let valid_lead_identifier_char x =
- match x with
- | 'a'..'z' | '_' -> true
- | _ -> false
+ | Not_String_Lteral
+ ->
+ Location.raise_errorf ~loc "bs.raw can only be applied to a string"
+ | JS_Regex_Check_Failed
+ ->
+ Location.raise_errorf ~loc "this is an invalid js regex"
+ end
-let valid_identifier_char x =
- match x with
- | 'a'..'z'
- | 'A'..'Z'
- | '0'..'9'
- | '_' | '\''-> true
- | _ -> false
-(** Invariant: [valid_lead_identifier] has to be [valid_identifier] *)
-let valid_identifier s =
- let s_len = String.length s in
- if s_len = 0 then false
- else
- valid_lead_identifier_char s.[0] &&
- Ext_string.for_all_from s 1 valid_identifier_char
+let ocaml_obj_as_js_object
+ loc (mapper : Bs_ast_mapper.mapper)
+ (self_pat : Parsetree.pattern)
+ (clfs : Parsetree.class_field list) =
+ let self_type_lit = "self_type" in
-
-let is_space x =
- match x with
- | ' ' | '\n' | '\t' -> true
- | _ -> false
+ (** Attention: we should avoid type variable conflict for each method
+ Since the method name is unique, there would be no conflict
+ OCaml does not allow duplicate instance variable and duplicate methods,
+ but it does allow duplicates between instance variable and method name,
+ we should enforce such rules
+ {[
+ object
+ val x = 3
+ method x = 3
+ end [@bs]
+ ]} should not compile with a meaningful error message
+ *)
+ let generate_val_method_pair
+ loc (mapper : Bs_ast_mapper.mapper)
+ val_name is_mutable =
+ let result = Typ.var ~loc val_name in
+ result ,
+ ((val_name , [], result ) ::
+ (if is_mutable then
+ [val_name ^ Literals.setter_suffix,[],
+ to_method_type loc mapper "" result (Ast_literal.type_unit ~loc ()) ]
+ else
+ []) )
+ in
+ (* Note mapper is only for API compatible
+ * TODO: we should check label name to avoid conflict
+ *)
+ let self_type loc = Typ.var ~loc self_type_lit in
-(**
- FIXME: multiple line offset
- if there is no line offset. Note {|{j||} border will never trigger a new line
-*)
-let update_position border
- ({lnum ; offset;byte_bol } : pos)
- (pos : Lexing.position)=
- if lnum = 0 then
- {pos with pos_cnum = pos.pos_cnum + border + offset }
- (** When no newline, the column number is [border + offset] *)
- else
- {
- pos with
- pos_lnum = pos.pos_lnum + lnum ;
- pos_bol = pos.pos_cnum + border + byte_bol;
- pos_cnum = pos.pos_cnum + border + byte_bol + offset;
- (** when newline, the column number is [offset] *)
- }
-let update border
- (start : pos)
- (finish : pos) (loc : Location.t) : Location.t =
- let start_pos = loc.loc_start in
- { loc with
- loc_start =
- update_position border start start_pos;
- loc_end =
- update_position border finish start_pos
- }
+ let generate_arg_type loc (mapper : Bs_ast_mapper.mapper)
+ method_name arity : Ast_core_type.t =
+ let result = Typ.var ~loc method_name in
+ if arity = 0 then
+ to_method_type loc mapper "" (Ast_literal.type_unit ~loc ()) result
+ else
+ let tyvars =
+ Ext_list.init arity (fun i -> Typ.var ~loc (method_name ^ string_of_int i))
+ in
+ begin match tyvars with
+ | x :: rest ->
+ let method_rest =
+ Ext_list.fold_right (fun v acc -> Typ.arrow ~loc "" v acc)
+ rest result in
+ to_method_type loc mapper "" x method_rest
+ | _ -> assert false
+ end in
-(** Note [Var] kind can not be mpty *)
-let empty_segment {content } =
- Ext_string.is_empty content
+ let generate_method_type
+ loc
+ (mapper : Bs_ast_mapper.mapper)
+ ?alias_type method_name arity =
+ let result = Typ.var ~loc method_name in
+ let self_type =
+ let v = self_type loc in
+ match alias_type with
+ | None -> v
+ | Some ty -> Typ.alias ~loc ty self_type_lit
+ in
+ if arity = 0 then
+ to_method_callback_type loc mapper "" self_type result
+ else
+ let tyvars =
+ Ext_list.init arity (fun i -> Typ.var ~loc (method_name ^ string_of_int i))
+ in
+ begin match tyvars with
+ | x :: rest ->
+ let method_rest =
+ Ext_list.fold_right (fun v acc -> Typ.arrow ~loc "" v acc)
+ rest result in
+ (to_method_callback_type loc mapper "" self_type
+ (Typ.arrow ~loc "" x method_rest))
+ | _ -> assert false
+ end in
-let update_newline ~byte_bol loc cxt =
- cxt.pos_lnum <- cxt.pos_lnum + 1 ;
- cxt.pos_bol <- loc;
- cxt.byte_bol <- byte_bol
+ (** we need calculate the real object type
+ and exposed object type, in some cases there are equivalent
-let pos_error cxt ~loc error =
- raise (Error
- (cxt.segment_start,
- { lnum = cxt.pos_lnum ; offset = loc - cxt.pos_bol ; byte_bol = cxt.byte_bol}, error))
+ for public object type its [@bs.meth] it does not depend on itself
+ while for label argument it is [@bs.this] which depends internal object
+ *)
+ let internal_label_attr_types, public_label_attr_types =
+ Ext_list.fold_right
+ (fun ({pcf_loc = loc} as x : Parsetree.class_field)
+ (label_attr_types, public_label_attr_types) ->
+ match x.pcf_desc with
+ | Pcf_method (
+ label,
+ public_flag,
+ Cfk_concrete
+ (Fresh, e))
+ ->
+ begin match e.pexp_desc with
+ | Pexp_poly
+ (({pexp_desc = Pexp_fun ("", None, pat, e)} ),
+ None) ->
+ let arity = Ast_pat.arity_of_fun pat e in
+ let method_type =
+ generate_arg_type x.pcf_loc mapper label.txt arity in
+ ((label.Asttypes.txt, [], method_type) :: label_attr_types),
+ (if public_flag = Public then
+ (label.Asttypes.txt, [], method_type) :: public_label_attr_types
+ else
+ public_label_attr_types)
-let add_var_segment cxt loc =
- let content = Buffer.contents cxt.buf in
- Buffer.clear cxt.buf ;
- let next_loc = {
- lnum = cxt.pos_lnum ; offset = loc - cxt.pos_bol ;
- byte_bol = cxt.byte_bol } in
- if valid_identifier content then
- begin
- cxt.segments <-
- { start = cxt.segment_start;
- finish = next_loc ;
- kind = Var;
- content} :: cxt.segments ;
- cxt.segment_start <- next_loc
- end
- else pos_error cxt ~loc (Invalid_syntax_of_var content)
+ | Pexp_poly( _, Some _)
+ ->
+ Location.raise_errorf ~loc "polymorphic type annotation not supported yet"
+ | Pexp_poly (_, None) ->
+ Location.raise_errorf ~loc
+ "Unsupported syntax, expect syntax like `method x () = x ` "
+ | _ ->
+ Location.raise_errorf ~loc "Unsupported syntax in js object"
+ end
+ | Pcf_val (label, mutable_flag, Cfk_concrete(Fresh, val_exp)) ->
+ let label_type, label_attr =
+ generate_val_method_pair x.pcf_loc mapper label.txt
+ (mutable_flag = Mutable )
+ in
+ (Ext_list.append label_attr label_attr_types, public_label_attr_types)
+ | Pcf_val (label, mutable_flag, Cfk_concrete(Override, val_exp)) ->
+ Location.raise_errorf ~loc "override flag not support currently"
+ | Pcf_val (label, mutable_flag, Cfk_virtual _) ->
+ Location.raise_errorf ~loc "virtual flag not support currently"
-let add_str_segment cxt loc =
- let content = Buffer.contents cxt.buf in
- Buffer.clear cxt.buf ;
- let next_loc = {
- lnum = cxt.pos_lnum ; offset = loc - cxt.pos_bol ;
- byte_bol = cxt.byte_bol } in
- cxt.segments <-
- { start = cxt.segment_start;
- finish = next_loc ;
- kind = String;
- content} :: cxt.segments ;
- cxt.segment_start <- next_loc
+ | Pcf_method (_, _, Cfk_concrete(Override, _) ) ->
+ Location.raise_errorf ~loc "override flag not supported"
+
+ | Pcf_method (_, _, Cfk_virtual _ )
+ ->
+ Location.raise_errorf ~loc "virtural method not supported"
+
+ | Pcf_inherit _
+ | Pcf_initializer _
+ | Pcf_attribute _
+ | Pcf_extension _
+ | Pcf_constraint _ ->
+ Location.raise_errorf ~loc "Only method support currently"
+ ) clfs ([], []) in
+ let internal_obj_type = Ast_core_type.make_obj ~loc internal_label_attr_types in
+ let public_obj_type = Ast_core_type.make_obj ~loc public_label_attr_types in
+ let (labels, label_types, exprs, _) =
+ Ext_list.fold_right
+ (fun (x : Parsetree.class_field)
+ (labels,
+ label_types,
+ exprs, aliased ) ->
+ match x.pcf_desc with
+ | Pcf_method (
+ label,
+ _public_flag,
+ Cfk_concrete
+ (Fresh, e))
+ ->
+ begin match e.pexp_desc with
+ | Pexp_poly
+ (({pexp_desc = Pexp_fun ("", None, pat, e)} as f),
+ None) ->
+ let arity = Ast_pat.arity_of_fun pat e in
+ let alias_type =
+ if aliased then None
+ else Some internal_obj_type in
+ let label_type =
+ generate_method_type ?alias_type
+ x.pcf_loc mapper label.txt arity in
+ (label::labels,
+ label_type::label_types,
+ {f with
+ pexp_desc =
+ let f = Ast_pat.is_unit_cont pat ~yes:e ~no:f in
+ to_method_callback loc mapper self_pat f
+ } :: exprs,
+ true
+ )
+ | Pexp_poly( _, Some _)
+ ->
+ Location.raise_errorf ~loc
+ "polymorphic type annotation not supported yet"
+ | Pexp_poly (_, None) ->
+ Location.raise_errorf
+ ~loc "Unsupported syntax, expect syntax like `method x () = x ` "
+ | _ ->
+ Location.raise_errorf ~loc "Unsupported syntax in js object"
+ end
+ | Pcf_val (label, mutable_flag, Cfk_concrete(Fresh, val_exp)) ->
+ let label_type, label_attr =
+ generate_val_method_pair x.pcf_loc mapper label.txt
+ (mutable_flag = Mutable )
+ in
+ (label::labels,
+ label_type :: label_types,
+ (mapper.expr mapper val_exp :: exprs),
+ aliased
+ )
-
+ | Pcf_val (label, mutable_flag, Cfk_concrete(Override, val_exp)) ->
+ Location.raise_errorf ~loc "override flag not support currently"
+ | Pcf_val (label, mutable_flag, Cfk_virtual _) ->
+ Location.raise_errorf ~loc "virtual flag not support currently"
+ | Pcf_method (_, _, Cfk_concrete(Override, _) ) ->
+ Location.raise_errorf ~loc "override flag not supported"
-let rec check_and_transform (loc : int ) s byte_offset ({s_len; buf} as cxt : cxt) =
- if byte_offset = s_len then
- add_str_segment cxt loc
- else
- let current_char = s.[byte_offset] in
- match Ext_utf8.classify current_char with
- | Single 92 (* '\\' *) ->
- escape_code (loc + 1) s (byte_offset+1) cxt
- | Single 34 ->
- Buffer.add_string buf "\\\"";
- check_and_transform (loc + 1) s (byte_offset + 1) cxt
- | Single 39 ->
- Buffer.add_string buf "\\'";
- check_and_transform (loc + 1) s (byte_offset + 1) cxt
- | Single 10 ->
+ | Pcf_method (_, _, Cfk_virtual _ )
+ ->
+ Location.raise_errorf ~loc "virtural method not supported"
- Buffer.add_string buf "\\n";
- let loc = loc + 1 in
- let byte_offset = byte_offset + 1 in
- update_newline ~byte_bol:byte_offset loc cxt ; (* Note variable could not have new-line *)
- check_and_transform loc s byte_offset cxt
- | Single 13 ->
- Buffer.add_string buf "\\r";
- check_and_transform (loc + 1) s (byte_offset + 1) cxt
- | Single 36 -> (* $ *)
- add_str_segment cxt loc ;
- let offset = byte_offset + 1 in
- if offset >= s_len then
- pos_error ~loc cxt Unterminated_variable
- else
- let cur_char = s.[offset] in
- if cur_char = '(' then
- expect_var_paren (loc + 2) s (offset + 1) cxt
- else
- expect_simple_var (loc + 1) s offset cxt
- | Single _ ->
- Buffer.add_char buf current_char;
- check_and_transform (loc + 1) s (byte_offset + 1) cxt
- | Invalid
- | Cont _ -> pos_error ~loc cxt Invalid_code_point
- | Leading (n,_) ->
- let i' = Ext_utf8.next s ~remaining:n byte_offset in
- if i' < 0 then
- pos_error cxt ~loc Invalid_code_point
- else
- begin
- for k = byte_offset to i' do
- Buffer.add_char buf s.[k];
- done;
- check_and_transform (loc + 1 ) s (i' + 1) cxt
- end
-(**Lets keep identifier simple, so that we could generating a function easier in the future
- for example
- let f = [%fn{| $x + $y = $x_add_y |}]
-*)
-and expect_simple_var loc s offset ({buf; s_len} as cxt) =
- let v = ref offset in
- (* prerr_endline @@ Ext_pervasives.dump (s, has_paren, (is_space s.[!v]), !v); *)
- if not (offset < s_len && valid_lead_identifier_char s.[offset]) then
- pos_error cxt ~loc (Invalid_syntax_of_var Ext_string.empty)
- else
- begin
- while !v < s_len && valid_identifier_char s.[!v] do (* TODO*)
- let cur_char = s.[!v] in
- Buffer.add_char buf cur_char;
- incr v ;
- done;
- let added_length = !v - offset in
- let loc = added_length + loc in
- add_var_segment cxt loc ;
- check_and_transform loc s (added_length + offset) cxt
- end
-and expect_var_paren loc s offset ({buf; s_len} as cxt) =
- let v = ref offset in
- (* prerr_endline @@ Ext_pervasives.dump (s, has_paren, (is_space s.[!v]), !v); *)
- while !v < s_len && s.[!v] <> ')' do
- let cur_char = s.[!v] in
- Buffer.add_char buf cur_char;
- incr v ;
- done;
- let added_length = !v - offset in
- let loc = added_length + 1 + loc in
- if !v < s_len && s.[!v] = ')' then
- begin
- add_var_segment cxt loc ;
- check_and_transform loc s (added_length + 1 + offset) cxt
- end
- else
- pos_error cxt ~loc Unmatched_paren
+ | Pcf_inherit _
+ | Pcf_initializer _
+ | Pcf_attribute _
+ | Pcf_extension _
+ | Pcf_constraint _ ->
+ Location.raise_errorf ~loc "Only method support currently"
+ ) clfs ([], [], [], false) in
+ let pval_type =
+ Ext_list.fold_right2
+ (fun label label_type acc ->
+ Typ.arrow
+ ~loc:label.Asttypes.loc
+ label.Asttypes.txt
+ label_type acc
+ ) labels label_types public_obj_type in
+ Ast_external_mk.local_extern_cont
+ loc
+ ~pval_prim:(External_process.pval_prim_of_labels labels)
+ (fun e ->
+ Exp.apply ~loc e
+ (Ext_list.map2 (fun l expr -> l.Asttypes.txt, expr) labels exprs) )
+ ~pval_type
+let record_as_js_object
+ loc
+ (self : Bs_ast_mapper.mapper)
+ (label_exprs : label_exprs)
+ : Parsetree.expression_desc =
+ let labels,args, arity =
+ Ext_list.fold_right (fun ({Location.txt ; loc}, e) (labels,args,i) ->
+ match txt with
+ | Longident.Lident x ->
+ ({Asttypes.loc = loc ; txt = x} :: labels, (x, self.expr self e) :: args, i + 1)
+ | Ldot _ | Lapply _ ->
+ Location.raise_errorf ~loc "invalid js label ") label_exprs ([],[],0) in
+ Ast_external_mk.local_external loc
+ ~pval_prim:(External_process.pval_prim_of_labels labels)
+ ~pval_type:(Ast_core_type.from_labels ~loc arity labels)
+ args
-(* we share the same escape sequence with js *)
-and escape_code loc s offset ({ buf; s_len} as cxt) =
- if offset >= s_len then
- pos_error cxt ~loc Unterminated_backslash
- else
- Buffer.add_char buf '\\';
- let cur_char = s.[offset] in
- match cur_char with
- | '\\'
- | 'b'
- | 't'
- | 'n'
- | 'v'
- | 'f'
- | 'r'
- | '0'
- | '$'
- ->
- begin
- Buffer.add_char buf cur_char ;
- check_and_transform (loc + 1) s (offset + 1) cxt
- end
- | 'u' ->
- begin
- Buffer.add_char buf cur_char;
- unicode (loc + 1) s (offset + 1) cxt
- end
- | 'x' -> begin
- Buffer.add_char buf cur_char ;
- two_hex (loc + 1) s (offset + 1) cxt
- end
- | _ -> pos_error cxt ~loc (Invalid_escape_code cur_char)
-and two_hex loc s offset ({buf ; s_len} as cxt) =
- if offset + 1 >= s_len then
- pos_error cxt ~loc Invalid_hex_escape;
- let a, b = s.[offset], s.[offset + 1] in
- if Ext_char.valid_hex a && Ext_char.valid_hex b then
- begin
- Buffer.add_char buf a ;
- Buffer.add_char buf b ;
- check_and_transform (loc + 2) s (offset + 2) cxt
- end
- else
- pos_error cxt ~loc Invalid_hex_escape
+let isCamlExceptionOrOpenVariant = Longident.parse "Caml_exceptions.isCamlExceptionOrOpenVariant"
+let obj_magic = Longident.parse "Obj.magic"
-and unicode loc s offset ({buf ; s_len} as cxt) =
- if offset + 3 >= s_len then
- pos_error cxt ~loc Invalid_unicode_escape
- ;
- let a0,a1,a2,a3 = s.[offset], s.[offset+1], s.[offset+2], s.[offset+3] in
- if
- Ext_char.valid_hex a0 &&
- Ext_char.valid_hex a1 &&
- Ext_char.valid_hex a2 &&
- Ext_char.valid_hex a3 then
- begin
- Buffer.add_char buf a0;
- Buffer.add_char buf a1;
- Buffer.add_char buf a2;
- Buffer.add_char buf a3;
- check_and_transform (loc + 4) s (offset + 4) cxt
- end
- else
- pos_error cxt ~loc Invalid_unicode_escape
-let transform_test s =
- let s_len = String.length s in
- let buf = Buffer.create (s_len * 2) in
- let cxt =
- { segment_start = {lnum = 0; offset = 0; byte_bol = 0};
- buf ;
- s_len;
- segments = [];
- pos_lnum = 0;
- byte_bol = 0;
- pos_bol = 0;
+let rec checkCases (cases : Parsetree.case list) =
+ List.iter check_case cases
+and check_case case =
+ check_pat case.pc_lhs
+and check_pat (pat : Parsetree.pattern) =
+ match pat.ppat_desc with
+ | Ppat_construct _ -> ()
+ | Ppat_or (l,r) ->
+ check_pat l; check_pat r
+ | _ -> Location.raise_errorf ~loc:pat.ppat_loc "Unsupported pattern in `bs.open`"
- } in
- check_and_transform 0 s 0 cxt;
- List.rev cxt.segments
+let convertBsErrorFunction loc (self : Bs_ast_mapper.mapper) attrs (cases : Parsetree.case list ) =
+ let txt = "match" in
+ let txt_expr = Exp.ident ~loc {txt = Lident txt; loc} in
+ let none = Exp.constraint_ ~loc
+ (Exp.construct ~loc {txt = Lident "None" ; loc} None)
+ (Ast_core_type.lift_option_type (Typ.any ~loc ())) in
+ let () = checkCases cases in
+ let cases = self.cases self cases in
+ Exp.fun_ ~attrs ~loc "" None ( Pat.var ~loc {txt; loc })
+ (Exp.ifthenelse
+ ~loc
+ (Exp.apply ~loc (Exp.ident ~loc {txt = isCamlExceptionOrOpenVariant ; loc}) ["", txt_expr ])
+ (Exp.match_ ~loc
+ (Exp.constraint_ ~loc
+ (Exp.apply ~loc (Exp.ident ~loc {txt = obj_magic; loc}) ["", txt_expr])
+ (Ast_literal.type_exn ~loc ())
+ )
+ (Ext_list.map_append (fun (x :Parsetree.case ) ->
+ let pc_rhs = x.pc_rhs in
+ let loc = pc_rhs.pexp_loc in
+ {
+ x with pc_rhs =
+ Exp.constraint_ ~loc
+ (Exp.construct ~loc {txt = Lident "Some";loc} (Some pc_rhs))
+ (Ast_core_type.lift_option_type (Typ.any ~loc ()) )
+ }
+ ) cases
+ [
+ Exp.case (Pat.any ~loc ()) none
+ ])
+ )
+ (Some none))
+
+
-(** TODO: test empty var $() $ failure,
- Allow identifers x.A.y *)
+end
+module Ext_ref : sig
+#1 "ext_ref.mli"
+(* 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. *)
-open Ast_helper
+(** [non_exn_protect ref value f] assusme [f()]
+ would not raise
+*)
-(** Longident.parse "Pervasives.^" *)
-let concat_ident : Longident.t =
- Ldot (Lident "Pervasives", "^")
- (* JS string concatMany *)
- (* Ldot (Ldot (Lident "Js", "String"), "concat") *)
+val non_exn_protect : 'a ref -> 'a -> (unit -> 'b) -> 'b
+val protect : 'a ref -> 'a -> (unit -> 'b) -> 'b
-(* Longident.parse "Js.String.make" *)
-let to_string_ident : Longident.t =
- Ldot (Ldot (Lident "Js", "String"), "make")
+val protect2 : 'a ref -> 'b ref -> 'a -> 'b -> (unit -> 'c) -> 'c
+(** [non_exn_protect2 refa refb va vb f ]
+ assume [f ()] would not raise
+*)
+val non_exn_protect2 : 'a ref -> 'b ref -> 'a -> 'b -> (unit -> 'c) -> 'c
+val protect_list : ('a ref * 'a) list -> (unit -> 'b) -> 'b
-let escaped = Some Literals.escaped_j_delimiter
+end = struct
+#1 "ext_ref.ml"
+(* 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 concat_exp
- (a : Parsetree.expression)
- (b : Parsetree.expression) : Parsetree.expression =
- let loc = Bs_loc.merge a.pexp_loc b.pexp_loc in
- Exp.apply ~loc
- (Exp.ident { txt =concat_ident; loc})
- ["",a ;
- "",b]
+let non_exn_protect r v body =
+ let old = !r in
+ r := v;
+ let res = body() in
+ r := old;
+ res
-let border = String.length "{j|"
+let protect r v body =
+ let old = !r in
+ try
+ r := v;
+ let res = body() in
+ r := old;
+ res
+ with x ->
+ r := old;
+ raise x
-let aux loc (segment : segment) =
- match segment with
- | {start ; finish; kind ; content}
- ->
- let loc = update border start finish loc in
- begin match kind with
- | String ->
- Exp.constant
- ~loc
- (Const_string (content, escaped))
- | Var ->
- Exp.apply ~loc
- (Exp.ident ~loc {loc ; txt = to_string_ident })
- [
- "",
- Exp.ident ~loc {loc ; txt = Lident content}
- ]
- end
+let non_exn_protect2 r1 r2 v1 v2 body =
+ let old1 = !r1 in
+ let old2 = !r2 in
+ r1 := v1;
+ r2 := v2;
+ let res = body() in
+ r1 := old1;
+ r2 := old2;
+ res
+let protect2 r1 r2 v1 v2 body =
+ let old1 = !r1 in
+ let old2 = !r2 in
+ try
+ r1 := v1;
+ r2 := v2;
+ let res = body() in
+ r1 := old1;
+ r2 := old2;
+ res
+ with x ->
+ r1 := old1;
+ r2 := old2;
+ raise x
-let transform_interp loc s =
- let s_len = String.length s in
- let buf = Buffer.create (s_len * 2 ) in
+let protect_list rvs body =
+ let olds = Ext_list.map (fun (x,y) -> !x) rvs in
+ let () = List.iter (fun (x,y) -> x:=y) rvs in
try
- let cxt : cxt =
- { segment_start = {lnum = 0; offset = 0; byte_bol = 0};
- buf ;
- s_len;
- segments = [];
- pos_lnum = 0;
- byte_bol = 0;
- pos_bol = 0;
-
- } in
-
- check_and_transform 0 s 0 cxt;
- let rev_segments = cxt.segments in
- match rev_segments with
- | [] ->
- Exp.constant ~loc
- (Const_string ("", Some Literals.escaped_j_delimiter))
- | [ segment] ->
- aux loc segment
- | a::rest ->
- List.fold_left (fun (acc : Parsetree.expression)
- (x : segment) ->
- concat_exp (aux loc x) acc )
- (aux loc a) rest
- with
- Error (start,pos, error)
- ->
- Location.raise_errorf ~loc:(update border start pos loc )
- "%a" pp_error error
+ let res = body () in
+ List.iter2 (fun (x,_) old -> x := old) rvs olds;
+ res
+ with e ->
+ List.iter2 (fun (x,_) old -> x := old) rvs olds;
+ raise e
end
-module Ast_exp : sig
-#1 "ast_exp.mli"
-(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+module Ast_core_type_class_type : sig
+#1 "ast_core_type_class_type.mli"
+(* Copyright (C) 2018 Authors of BuckleScript
*
* 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
@@ -107833,11 +108779,21 @@ module Ast_exp : sig
* 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.expression
+
+val handle_class_type_fields :
+ Bs_ast_mapper.mapper ->
+ Parsetree.class_type_field list ->
+ Parsetree.class_type_field list
+
+val handle_core_type :
+ Bs_ast_mapper.mapper ->
+ Parsetree.core_type ->
+ bool ref ->
+ Parsetree.core_type
end = struct
-#1 "ast_exp.ml"
-(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+#1 "ast_core_type_class_type.ml"
+(* Copyright (C) 2018 Authors of BuckleScript
*
* 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
@@ -107860,65 +108816,203 @@ end = struct
* 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. *)
+open Ast_helper
+let process_getter_setter ~no ~get ~set
+ loc name
+ (attrs : Ast_attributes.t)
+ (ty : Parsetree.core_type) acc =
+ match Ast_attributes.process_method_attributes_rev attrs with
+ | {get = None; set = None}, _ -> no ty :: acc
+ | st , pctf_attributes
+ ->
+ let get_acc =
+ match st.set with
+ | Some `No_get -> acc
+ | None
+ | Some `Get ->
+ let lift txt =
+ Typ.constr ~loc {txt ; loc} [ty] in
+ let (null,undefined) =
+ match st with
+ | {get = Some (null, undefined) } -> (null, undefined)
+ | {get = None} -> (false, false ) in
+ let ty =
+ match (null,undefined) with
+ | false, false -> ty
+ | true, false -> lift Ast_literal.Lid.js_null
+ | false, true -> lift Ast_literal.Lid.js_undefined
+ | true , true -> lift Ast_literal.Lid.js_null_undefined in
+ get ty name pctf_attributes
+ :: acc
+ in
+ if st.set = None then get_acc
+ else
+ set ty (name ^ Literals.setter_suffix) pctf_attributes
+ :: get_acc
+
+
+let handle_class_type_field self
+ ({pctf_loc = loc } as ctf : Parsetree.class_type_field)
+ acc =
+ match ctf.pctf_desc with
+ | Pctf_method
+ (name, private_flag, virtual_flag, ty)
+ ->
+ let no (ty : Parsetree.core_type) =
+ let ty =
+ match ty.ptyp_desc with
+ | Ptyp_arrow (label, args, body)
+ ->
+ Ast_util.to_method_type
+ ty.ptyp_loc self label args body
-type t = Parsetree.expression
+ | Ptyp_poly (strs, {ptyp_desc = Ptyp_arrow (label, args, body);
+ ptyp_loc})
+ ->
+ {ty with ptyp_desc =
+ Ptyp_poly(strs,
+ Ast_util.to_method_type
+ ptyp_loc self label args body )}
+ | _ ->
+ self.typ self ty
+ in
+ {ctf with
+ pctf_desc =
+ Pctf_method (name , private_flag, virtual_flag, ty)}
+ in
+ let get ty name pctf_attributes =
+ {ctf with
+ pctf_desc =
+ Pctf_method (name ,
+ private_flag,
+ virtual_flag,
+ self.typ self ty
+ );
+ pctf_attributes} in
+ let set ty name pctf_attributes =
+ {ctf with
+ pctf_desc =
+ Pctf_method (name,
+ private_flag,
+ virtual_flag,
+ Ast_util.to_method_type
+ loc self "" ty
+ (Ast_literal.type_unit ~loc ())
+ );
+ pctf_attributes} in
+ process_getter_setter ~no ~get ~set loc name ctf.pctf_attributes ty acc
-end
-module Ast_external_mk : sig
-#1 "ast_external_mk.mli"
-(* 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. *)
+ | Pctf_inherit _
+ | Pctf_val _
+ | Pctf_constraint _
+ | Pctf_attribute _
+ | Pctf_extension _ ->
+ Bs_ast_mapper.default_mapper.class_type_field self ctf :: acc
+
-(**
- [local_module loc ~pval_prim ~pval_type args]
- generate such code
- {[
- let module J = struct
- external unsafe_expr : pval_type = pval_prim
- end in
- J.unssafe_expr args
- ]}
+(*
+ Attributes are very hard to attribute
+ (since ptyp_attributes could happen in so many places),
+ and write ppx extensions correctly,
+ we can only use it locally
*)
-val local_external : Location.t ->
- ?pval_attributes:Parsetree.attributes ->
- pval_prim:string list ->
- pval_type:Parsetree.core_type ->
- ?local_module_name:string ->
- ?local_fun_name:string ->
- (string * Parsetree.expression) list -> Parsetree.expression_desc
-
-val local_extern_cont :
- Location.t ->
- ?pval_attributes:Parsetree.attributes ->
- pval_prim:string list ->
- pval_type:Parsetree.core_type ->
- ?local_module_name:string ->
- ?local_fun_name:string ->
- (Parsetree.expression -> Parsetree.expression) -> Parsetree.expression_desc
-end = struct
-#1 "ast_external_mk.ml"
+let handle_core_type
+ ~(super : Bs_ast_mapper.mapper)
+ ~(self : Bs_ast_mapper.mapper)
+ (ty : Parsetree.core_type)
+ record_as_js_object
+ =
+ match ty with
+ | {ptyp_desc = Ptyp_extension({txt = ("bs.obj"|"obj")}, PTyp ty)}
+ ->
+ Ext_ref.non_exn_protect record_as_js_object true
+ (fun _ -> self.typ self ty )
+ | {ptyp_attributes ;
+ ptyp_desc = Ptyp_arrow (label, args, body);
+ (* let it go without regard label names,
+ it will report error later when the label is not empty
+ *)
+ ptyp_loc = loc
+ } ->
+ begin match Ast_attributes.process_attributes_rev ptyp_attributes with
+ | `Uncurry , ptyp_attributes ->
+ Ast_util.to_uncurry_type loc self label args body
+ | `Meth_callback, ptyp_attributes ->
+ Ast_util.to_method_callback_type loc self label args body
+ | `Method, ptyp_attributes ->
+ Ast_util.to_method_type loc self label args body
+ | `Nothing , _ ->
+ Bs_ast_mapper.default_mapper.typ self ty
+ end
+ | {
+ ptyp_desc = Ptyp_object ( methods, closed_flag) ;
+ ptyp_loc = loc
+ } ->
+ let (+>) attr (typ : Parsetree.core_type) =
+ {typ with ptyp_attributes = attr :: typ.ptyp_attributes} in
+ let new_methods =
+ Ext_list.fold_right (fun (label, ptyp_attrs, core_type) acc ->
+ let get ty name attrs =
+ let attrs, core_type =
+ match Ast_attributes.process_attributes_rev attrs with
+ | `Nothing, attrs -> attrs, ty (* #1678 *)
+ | `Uncurry, attrs ->
+ attrs, Ast_attributes.bs +> ty
+ | `Method, _
+ -> Location.raise_errorf ~loc "bs.get/set conflicts with bs.meth"
+ | `Meth_callback, attrs ->
+ attrs, Ast_attributes.bs_this +> ty
+ in
+ name , attrs, self.typ self core_type in
+ let set ty name attrs =
+ let attrs, core_type =
+ match Ast_attributes.process_attributes_rev attrs with
+ | `Nothing, attrs -> attrs, ty
+ | `Uncurry, attrs ->
+ attrs, Ast_attributes.bs +> ty
+ | `Method, _
+ -> Location.raise_errorf ~loc "bs.get/set conflicts with bs.meth"
+ | `Meth_callback, attrs ->
+ attrs, Ast_attributes.bs_this +> ty
+ in
+ name, attrs, Ast_util.to_method_type loc self "" core_type
+ (Ast_literal.type_unit ~loc ()) in
+ let no ty =
+ let attrs, core_type =
+ match Ast_attributes.process_attributes_rev ptyp_attrs with
+ | `Nothing, attrs -> attrs, ty
+ | `Uncurry, attrs ->
+ attrs, Ast_attributes.bs +> ty
+ | `Method, attrs ->
+ attrs, Ast_attributes.bs_method +> ty
+ | `Meth_callback, attrs ->
+ attrs, Ast_attributes.bs_this +> ty in
+ label, attrs, self.typ self core_type in
+ process_getter_setter ~no ~get ~set
+ loc label ptyp_attrs core_type acc
+ ) methods [] in
+ let inner_type =
+ { ty
+ with ptyp_desc = Ptyp_object(new_methods, closed_flag);
+ } in
+ if !record_as_js_object then
+ Ast_comb.to_js_type loc inner_type
+ else inner_type
+ | _ -> super.typ self ty
+
+let handle_class_type_fields self fields =
+ Ext_list.fold_right
+ (handle_class_type_field self)
+ fields []
+
+let handle_core_type self typ record_as_js_object =
+ handle_core_type
+ ~super:Bs_ast_mapper.default_mapper
+ ~self typ record_as_js_object
+end
+module Ast_signature : sig
+#1 "ast_signature.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -107943,73 +109037,13 @@ end = struct
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-let 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_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
- })
+type item = Parsetree.signature_item
+type t = item list
-let local_extern_cont loc
- ?(pval_attributes=[])
- ~pval_prim
- ~pval_type
- ?(local_module_name = "J")
- ?(local_fun_name = "unsafe_expr")
- (cb : Parsetree.expression -> 'a)
- : 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_attributes };
- pstr_loc = loc;
- }];
- pmod_loc = loc;
- pmod_attributes = []},
- cb {pexp_desc = Pexp_ident {txt = Ldot (Lident local_module_name, local_fun_name);
- loc};
- pexp_attributes = [] ;
- pexp_loc = loc}
-)
-end
-module Ast_pat : sig
-#1 "ast_pat.mli"
+val fuseAll : ?loc:Ast_helper.loc -> t -> item
+end = struct
+#1 "ast_signature.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -108034,19 +109068,17 @@ module Ast_pat : sig
* 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.pattern
-
-val is_unit_cont : yes:'a -> no:'a -> t -> 'a
-
-(** [arity_of_fun pat e] tells the arity of
- expression [fun pat -> e]*)
-val arity_of_fun : t -> Parsetree.expression -> int
-
+type item = Parsetree.signature_item
+type t = item list
-val is_single_variable_pattern_conservative : t -> bool
+open Ast_helper
-end = struct
-#1 "ast_pat.ml"
+let fuseAll ?(loc=Location.none) (t : t) : item =
+ Sig.include_ ~loc (Incl.mk ~loc (Mty.signature ~loc t))
+
+end
+module Ast_structure : sig
+#1 "ast_structure.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -108072,813 +109104,573 @@ end = struct
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-type t = Parsetree.pattern
-
-
-let is_unit_cont ~yes ~no (p : t) =
- match p with
- | {ppat_desc = Ppat_construct({txt = Lident "()"}, None)}
- -> yes
- | _ -> no
-
-
-(** [arity_of_fun pat e] tells the arity of
- expression [fun pat -> e]
-*)
-let arity_of_fun
- (pat : Parsetree.pattern)
- (e : Parsetree.expression) =
- let rec aux (e : Parsetree.expression) =
- match e.pexp_desc with
- | Pexp_fun ("", None, pat, e) ->
- 1 + aux e
- | Pexp_fun _
- -> Location.raise_errorf
- ~loc:e.pexp_loc "Label is not allowed in JS object"
- | _ -> 0 in
- is_unit_cont ~yes:0 ~no:1 pat + aux e
-
-
-let rec is_single_variable_pattern_conservative (p : t ) =
- match p.ppat_desc with
- | Parsetree.Ppat_any
- | Parsetree.Ppat_var _ -> true
- | Parsetree.Ppat_alias (p,_)
- | Parsetree.Ppat_constraint (p, _) ->
- is_single_variable_pattern_conservative p
-
- | _ -> false
-
-end
-module Bs_ast_mapper : sig
-#1 "bs_ast_mapper.mli"
-(***********************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Alain Frisch, LexiFi *)
-(* *)
-(* Copyright 2012 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(** The interface of a -ppx rewriter
-
- A -ppx rewriter is a program that accepts a serialized abstract syntax
- tree and outputs another, possibly modified, abstract syntax tree.
- This module encapsulates the interface between the compiler and
- the -ppx rewriters, handling such details as the serialization format,
- forwarding of command-line flags, and storing state.
-
- {!mapper} allows to implement AST rewriting using open recursion.
- A typical mapper would be based on {!default_mapper}, a deep
- identity mapper, and will fall back on it for handling the syntax it
- does not modify. For example:
-
- {[
-open Asttypes
-open Parsetree
-open Ast_mapper
-
-let test_mapper argv =
- { default_mapper with
- expr = fun mapper expr ->
- match expr with
- | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} ->
- Ast_helper.Exp.constant (Const_int 42)
- | other -> default_mapper.expr mapper other; }
-
-let () =
- register "ppx_test" test_mapper]}
-
- This -ppx rewriter, which replaces [[%test]] in expressions with
- the constant [42], can be compiled using
- [ocamlc -o ppx_test -I +compiler-libs ocamlcommon.cma ppx_test.ml].
-
- *)
-
- open Parsetree
-
- (** {2 A generic Parsetree mapper} *)
-
- type mapper = {
- attribute: mapper -> attribute -> attribute;
- attributes: mapper -> attribute list -> attribute list;
- case: mapper -> case -> case;
- cases: mapper -> case list -> case list;
- class_declaration: mapper -> class_declaration -> class_declaration;
- class_description: mapper -> class_description -> class_description;
- class_expr: mapper -> class_expr -> class_expr;
- class_field: mapper -> class_field -> class_field;
- class_signature: mapper -> class_signature -> class_signature;
- class_structure: mapper -> class_structure -> class_structure;
- class_type: mapper -> class_type -> class_type;
- class_type_declaration: mapper -> class_type_declaration
- -> class_type_declaration;
- class_type_field: mapper -> class_type_field -> class_type_field;
- constructor_declaration: mapper -> constructor_declaration
- -> constructor_declaration;
- expr: mapper -> expression -> expression;
- extension: mapper -> extension -> extension;
- extension_constructor: mapper -> extension_constructor
- -> extension_constructor;
- include_declaration: mapper -> include_declaration -> include_declaration;
- include_description: mapper -> include_description -> include_description;
- label_declaration: mapper -> label_declaration -> label_declaration;
- location: mapper -> Location.t -> Location.t;
- module_binding: mapper -> module_binding -> module_binding;
- module_declaration: mapper -> module_declaration -> module_declaration;
- module_expr: mapper -> module_expr -> module_expr;
- module_type: mapper -> module_type -> module_type;
- module_type_declaration: mapper -> module_type_declaration
- -> module_type_declaration;
- open_description: mapper -> open_description -> open_description;
- pat: mapper -> pattern -> pattern;
- payload: mapper -> payload -> payload;
- signature: mapper -> signature -> signature;
- signature_item: mapper -> signature_item -> signature_item;
- structure: mapper -> structure -> structure;
- structure_item: mapper -> structure_item -> structure_item;
- typ: mapper -> core_type -> core_type;
- type_declaration: mapper -> type_declaration -> type_declaration;
- type_extension: mapper -> type_extension -> type_extension;
- type_kind: mapper -> type_kind -> type_kind;
- value_binding: mapper -> value_binding -> value_binding;
-(* XXXXX *)
- value_bindings_rec: mapper -> value_binding list -> value_binding list;
- value_bindings: mapper -> value_binding list -> value_binding list;
-(* XXXXX *)
- value_description: mapper -> value_description -> value_description;
- with_constraint: mapper -> with_constraint -> with_constraint;
- }
- (** A mapper record implements one "method" per syntactic category,
- using an open recursion style: each method takes as its first
- argument the mapper to be applied to children in the syntax
- tree. *)
-
- val default_mapper: mapper
- (** A default mapper, which implements a "deep identity" mapping. *)
-
-end = struct
-#1 "bs_ast_mapper.ml"
-(***********************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Alain Frisch, LexiFi *)
-(* *)
-(* Copyright 2012 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* A generic Parsetree mapping class *)
-(* Adapted for BUcklescript with more flexibilty*)
-
-[@@@ocaml.warning "+9"]
-(* Ensure that record patterns don't miss any field. *)
+type item = Parsetree.structure_item
+type t = item list
-open Asttypes
-open Parsetree
-open Ast_helper
-open Location
+val fuseAll: ?loc:Ast_helper.loc -> t -> item
-type mapper = {
- attribute: mapper -> attribute -> attribute;
- attributes: mapper -> attribute list -> attribute list;
- case: mapper -> case -> case;
- cases: mapper -> case list -> case list;
- class_declaration: mapper -> class_declaration -> class_declaration;
- class_description: mapper -> class_description -> class_description;
- class_expr: mapper -> class_expr -> class_expr;
- class_field: mapper -> class_field -> class_field;
- class_signature: mapper -> class_signature -> class_signature;
- class_structure: mapper -> class_structure -> class_structure;
- class_type: mapper -> class_type -> class_type;
- class_type_declaration: mapper -> class_type_declaration
- -> class_type_declaration;
- class_type_field: mapper -> class_type_field -> class_type_field;
- constructor_declaration: mapper -> constructor_declaration
- -> constructor_declaration;
- expr: mapper -> expression -> expression;
- extension: mapper -> extension -> extension;
- extension_constructor: mapper -> extension_constructor
- -> extension_constructor;
- include_declaration: mapper -> include_declaration -> include_declaration;
- include_description: mapper -> include_description -> include_description;
- label_declaration: mapper -> label_declaration -> label_declaration;
- location: mapper -> Location.t -> Location.t;
- module_binding: mapper -> module_binding -> module_binding;
- module_declaration: mapper -> module_declaration -> module_declaration;
- module_expr: mapper -> module_expr -> module_expr;
- module_type: mapper -> module_type -> module_type;
- module_type_declaration: mapper -> module_type_declaration
- -> module_type_declaration;
- open_description: mapper -> open_description -> open_description;
- pat: mapper -> pattern -> pattern;
- payload: mapper -> payload -> payload;
- signature: mapper -> signature -> signature;
- signature_item: mapper -> signature_item -> signature_item;
- structure: mapper -> structure -> structure;
- structure_item: mapper -> structure_item -> structure_item;
- typ: mapper -> core_type -> core_type;
- type_declaration: mapper -> type_declaration -> type_declaration;
- type_extension: mapper -> type_extension -> type_extension;
- type_kind: mapper -> type_kind -> type_kind;
- value_binding: mapper -> value_binding -> value_binding;
-(* XXXX *)
- value_bindings_rec : mapper -> value_binding list -> value_binding list;
- value_bindings : mapper -> value_binding list -> value_binding list;
-(* XXXXX *)
- value_description: mapper -> value_description -> value_description;
- with_constraint: mapper -> with_constraint -> with_constraint;
-}
+(* val fuse_with_constraint:
+ ?loc:Ast_helper.loc ->
+ Parsetree.type_declaration list ->
+ t ->
+ Ast_signature.t ->
+ item *)
-let map_fst f (x, y) = (f x, y)
-let map_snd f (x, y) = (x, f y)
-let map_tuple f1 f2 (x, y) = (f1 x, f2 y)
-let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
-let map_opt f = function None -> None | Some x -> Some (f x)
+val constraint_ : ?loc:Ast_helper.loc -> t -> Ast_signature.t -> item
-let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt}
+end = struct
+#1 "ast_structure.ml"
+(* 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 T = struct
- (* Type expressions for the core language *)
+type item = Parsetree.structure_item
- let row_field sub = function
- | Rtag (l, attrs, b, tl) ->
- Rtag (l, sub.attributes sub attrs, b, List.map (sub.typ sub) tl)
- | Rinherit t -> Rinherit (sub.typ sub t)
+type t = item list
- let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} =
- let open Typ in
- let loc = sub.location sub loc in
- let attrs = sub.attributes sub attrs in
- match desc with
- | Ptyp_any -> any ~loc ~attrs ()
- | Ptyp_var s -> var ~loc ~attrs s
- | Ptyp_arrow (lab, t1, t2) ->
- arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2)
- | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl)
- | Ptyp_constr (lid, tl) ->
- constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
- | Ptyp_object (l, o) ->
- let f (s, a, t) = (s, sub.attributes sub a, sub.typ sub t) in
- object_ ~loc ~attrs (List.map f l) o
- | Ptyp_class (lid, tl) ->
- class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
- | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s
- | Ptyp_variant (rl, b, ll) ->
- variant ~loc ~attrs (List.map (row_field sub) rl) b ll
- | Ptyp_poly (sl, t) -> poly ~loc ~attrs sl (sub.typ sub t)
- | Ptyp_package (lid, l) ->
- package ~loc ~attrs (map_loc sub lid)
- (List.map (map_tuple (map_loc sub) (sub.typ sub)) l)
- | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x)
+open Ast_helper
- let map_type_declaration sub
- {ptype_name; ptype_params; ptype_cstrs;
- ptype_kind;
- ptype_private;
- ptype_manifest;
- ptype_attributes;
- ptype_loc} =
- Type.mk (map_loc sub ptype_name)
- ~params:(List.map (map_fst (sub.typ sub)) ptype_params)
- ~priv:ptype_private
- ~cstrs:(List.map
- (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub))
- ptype_cstrs)
- ~kind:(sub.type_kind sub ptype_kind)
- ?manifest:(map_opt (sub.typ sub) ptype_manifest)
- ~loc:(sub.location sub ptype_loc)
- ~attrs:(sub.attributes sub ptype_attributes)
- let map_type_kind sub = function
- | Ptype_abstract -> Ptype_abstract
- | Ptype_variant l ->
- Ptype_variant (List.map (sub.constructor_declaration sub) l)
- | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l)
- | Ptype_open -> Ptype_open
+let fuseAll ?(loc=Location.none) (t : t) : item =
+ Str.include_ ~loc
+ (Incl.mk ~loc (Mod.structure ~loc t ))
+
+(* let fuse_with_constraint
+ ?(loc=Location.none)
+ (item : Parsetree.type_declaration list ) (t : t) (coercion) =
+ Str.include_ ~loc
+ (Incl.mk ~loc
+ (Mod.constraint_
+ (Mod.structure ~loc
+ ({pstr_loc = loc; pstr_desc = Pstr_type item} :: t) )
+ (
+ Mty.signature ~loc
+ ({psig_loc = loc; psig_desc = Psig_type item} :: coercion)
+ )
+ )
+ ) *)
+let constraint_ ?(loc=Location.none) (stru : t) (sign : Ast_signature.t) =
+ Str.include_ ~loc
+ (Incl.mk ~loc
+ (Mod.constraint_ ~loc (Mod.structure ~loc stru) (Mty.signature ~loc sign)))
- let map_type_extension sub
- {ptyext_path; ptyext_params;
- ptyext_constructors;
- ptyext_private;
- ptyext_attributes} =
- Te.mk
- (map_loc sub ptyext_path)
- (List.map (sub.extension_constructor sub) ptyext_constructors)
- ~params:(List.map (map_fst (sub.typ sub)) ptyext_params)
- ~priv:ptyext_private
- ~attrs:(sub.attributes sub ptyext_attributes)
+end
+module Ast_derive : sig
+#1 "ast_derive.mli"
+(* 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 map_extension_constructor_kind sub = function
- Pext_decl(ctl, cto) ->
- Pext_decl(List.map (sub.typ sub) ctl, map_opt (sub.typ sub) cto)
- | Pext_rebind li ->
- Pext_rebind (map_loc sub li)
+type tdcls = Parsetree.type_declaration list
- let map_extension_constructor sub
- {pext_name;
- pext_kind;
- pext_loc;
- pext_attributes} =
- Te.constructor
- (map_loc sub pext_name)
- (map_extension_constructor_kind sub pext_kind)
- ~loc:(sub.location sub pext_loc)
- ~attrs:(sub.attributes sub pext_attributes)
+type gen = {
+ structure_gen : tdcls -> bool -> Ast_structure.t ;
+ signature_gen : tdcls -> bool -> Ast_signature.t ;
+ expression_gen : (Parsetree.core_type -> Parsetree.expression) option ;
+}
-end
+(**
+ [register name cb]
+ example: [register "accessors" cb]
+*)
+val register :
+ string ->
+ (Parsetree.expression option -> gen) ->
+ unit
-module CT = struct
- (* Type expressions for the class language *)
+(* val gen_structure:
+ tdcls ->
+ Ast_payload.action list ->
+ bool ->
+ Ast_structure.t *)
- let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} =
- let open Cty in
- let loc = sub.location sub loc in
- let attrs = sub.attributes sub attrs in
- match desc with
- | Pcty_constr (lid, tys) ->
- constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys)
- | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x)
- | Pcty_arrow (lab, t, ct) ->
- arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct)
- | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x)
+val gen_signature:
+ tdcls ->
+ Ast_payload.action list ->
+ bool ->
+ Ast_signature.t
- let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs}
- =
- let open Ctf in
- let loc = sub.location sub loc in
- let attrs = sub.attributes sub attrs in
- match desc with
- | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct)
- | Pctf_val (s, m, v, t) -> val_ ~loc ~attrs s m v (sub.typ sub t)
- | Pctf_method (s, p, v, t) -> method_ ~loc ~attrs s p v (sub.typ sub t)
- | Pctf_constraint (t1, t2) ->
- constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2)
- | Pctf_attribute x -> attribute ~loc (sub.attribute sub x)
- | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x)
- let map_signature sub {pcsig_self; pcsig_fields} =
- Csig.mk
- (sub.typ sub pcsig_self)
- (List.map (sub.class_type_field sub) pcsig_fields)
-end
+val gen_expression :
+ string Asttypes.loc ->
+ Parsetree.core_type ->
+ Parsetree.expression
+
+
+
+val gen_structure_signature :
+ Location.t ->
+ Parsetree.type_declaration list ->
+ Ast_payload.action ->
+ bool ->
+ Parsetree.structure_item
+end = struct
+#1 "ast_derive.ml"
+(* 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 MT = struct
- (* Type expressions for the module language *)
+type tdcls = Parsetree.type_declaration list
- let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} =
- let open Mty in
- let loc = sub.location sub loc in
- let attrs = sub.attributes sub attrs in
- match desc with
- | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s)
- | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s)
- | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg)
- | Pmty_functor (s, mt1, mt2) ->
- functor_ ~loc ~attrs (map_loc sub s)
- (Misc.may_map (sub.module_type sub) mt1)
- (sub.module_type sub mt2)
- | Pmty_with (mt, l) ->
- with_ ~loc ~attrs (sub.module_type sub mt)
- (List.map (sub.with_constraint sub) l)
- | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me)
- | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x)
+type gen = {
+ structure_gen : tdcls -> bool -> Ast_structure.t ;
+ signature_gen : tdcls -> bool -> Ast_signature.t ;
+ expression_gen : (Parsetree.core_type -> Parsetree.expression) option ;
+}
- let map_with_constraint sub = function
- | Pwith_type (lid, d) ->
- Pwith_type (map_loc sub lid, sub.type_declaration sub d)
- | Pwith_module (lid, lid2) ->
- Pwith_module (map_loc sub lid, map_loc sub lid2)
- | Pwith_typesubst d -> Pwith_typesubst (sub.type_declaration sub d)
- | Pwith_modsubst (s, lid) ->
- Pwith_modsubst (map_loc sub s, map_loc sub lid)
+(* the first argument is [config] payload
+ {[
+ { x = {uu} }
+ ]}
+*)
+type derive_table =
+ (Parsetree.expression option -> gen) String_map.t
- let map_signature_item sub {psig_desc = desc; psig_loc = loc} =
- let open Sig in
- let loc = sub.location sub loc in
- match desc with
- | Psig_value vd -> value ~loc (sub.value_description sub vd)
- | Psig_type l -> type_ ~loc (List.map (sub.type_declaration sub) l)
- | Psig_typext te -> type_extension ~loc (sub.type_extension sub te)
- | Psig_exception ed -> exception_ ~loc (sub.extension_constructor sub ed)
- | Psig_module x -> module_ ~loc (sub.module_declaration sub x)
- | Psig_recmodule l ->
- rec_module ~loc (List.map (sub.module_declaration sub) l)
- | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x)
- | Psig_open x -> open_ ~loc (sub.open_description sub x)
- | Psig_include x -> include_ ~loc (sub.include_description sub x)
- | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l)
- | Psig_class_type l ->
- class_type ~loc (List.map (sub.class_type_declaration sub) l)
- | Psig_extension (x, attrs) ->
- extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs)
- | Psig_attribute x -> attribute ~loc (sub.attribute sub x)
-end
+let derive_table : derive_table ref = ref String_map.empty
+let register key value =
+ derive_table := String_map.add key value !derive_table
-module M = struct
- (* Value expressions for the module language *)
- let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} =
- let open Mod in
- let loc = sub.location sub loc in
- let attrs = sub.attributes sub attrs in
- match desc with
- | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x)
- | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str)
- | Pmod_functor (arg, arg_ty, body) ->
- functor_ ~loc ~attrs (map_loc sub arg)
- (Misc.may_map (sub.module_type sub) arg_ty)
- (sub.module_expr sub body)
- | Pmod_apply (m1, m2) ->
- apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2)
- | Pmod_constraint (m, mty) ->
- constraint_ ~loc ~attrs (sub.module_expr sub m)
- (sub.module_type sub mty)
- | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e)
- | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x)
- let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} =
- let open Str in
- let loc = sub.location sub loc in
- match desc with
- | Pstr_eval (x, attrs) ->
- eval ~loc ~attrs:(sub.attributes sub attrs) (sub.expr sub x)
- | Pstr_value (r, vbs) ->
-(* XXX *)
-(* value ~loc r (List.map (sub.value_binding sub) vbs) *)
- value ~loc r
- ((if r = Recursive then sub.value_bindings_rec else sub.value_bindings)
- sub vbs)
-(* XXX *)
- | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd)
- | Pstr_type l -> type_ ~loc (List.map (sub.type_declaration sub) l)
- | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te)
- | Pstr_exception ed -> exception_ ~loc (sub.extension_constructor sub ed)
- | Pstr_module x -> module_ ~loc (sub.module_binding sub x)
- | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l)
- | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x)
- | Pstr_open x -> open_ ~loc (sub.open_description sub x)
- | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l)
- | Pstr_class_type l ->
- class_type ~loc (List.map (sub.class_type_declaration sub) l)
- | Pstr_include x -> include_ ~loc (sub.include_declaration sub x)
- | Pstr_extension (x, attrs) ->
- extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs)
- | Pstr_attribute x -> attribute ~loc (sub.attribute sub x)
-end
+(* let gen_structure
+ (tdcls : tdcls)
+ (actions : Ast_payload.action list )
+ (explict_nonrec : bool )
+ : Ast_structure.t =
+ Ext_list.flat_map
+ (fun action ->
+ (Ast_payload.table_dispatch !derive_table action).structure_gen
+ tdcls explict_nonrec) actions *)
-module E = struct
- (* Value expressions for the core language *)
+let gen_signature
+ tdcls
+ (actions : Ast_payload.action list )
+ (explict_nonrec : bool )
+ : Ast_signature.t =
+ Ext_list.flat_map
+ (fun action ->
+ (Ast_payload.table_dispatch !derive_table action).signature_gen
+ tdcls explict_nonrec) actions
- let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} =
- let open Exp in
- let loc = sub.location sub loc in
- let attrs = sub.attributes sub attrs in
- match desc with
- | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x)
- | Pexp_constant x -> constant ~loc ~attrs x
- | Pexp_let (r, vbs, e) ->
-(* XXXX *)
- (* let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs)
- (sub.expr sub e) *)
- let_ ~loc ~attrs r
- (
- (if r = Recursive then sub.value_bindings_rec else sub.value_bindings)
- sub vbs
- )
- (sub.expr sub e)
-(* XXXX *)
- | Pexp_fun (lab, def, p, e) ->
- fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p)
- (sub.expr sub e)
- | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel)
- | Pexp_apply (e, l) ->
- apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l)
- | Pexp_match (e, pel) ->
- match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
- | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
- | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el)
- | Pexp_construct (lid, arg) ->
- construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg)
- | Pexp_variant (lab, eo) ->
- variant ~loc ~attrs lab (map_opt (sub.expr sub) eo)
- | Pexp_record (l, eo) ->
- record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l)
- (map_opt (sub.expr sub) eo)
- | Pexp_field (e, lid) ->
- field ~loc ~attrs (sub.expr sub e) (map_loc sub lid)
- | Pexp_setfield (e1, lid, e2) ->
- setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid)
- (sub.expr sub e2)
- | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el)
- | Pexp_ifthenelse (e1, e2, e3) ->
- ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
- (map_opt (sub.expr sub) e3)
- | Pexp_sequence (e1, e2) ->
- sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
- | Pexp_while (e1, e2) ->
- while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2)
- | Pexp_for (p, e1, e2, d, e3) ->
- for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d
- (sub.expr sub e3)
- | Pexp_coerce (e, t1, t2) ->
- coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1)
- (sub.typ sub t2)
- | Pexp_constraint (e, t) ->
- constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t)
- | Pexp_send (e, s) -> send ~loc ~attrs (sub.expr sub e) s
- | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid)
- | Pexp_setinstvar (s, e) ->
- setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e)
- | Pexp_override sel ->
- override ~loc ~attrs
- (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel)
- | Pexp_letmodule (s, me, e) ->
- letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me)
- (sub.expr sub e)
- | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e)
- | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e)
- | Pexp_poly (e, t) ->
- poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t)
- | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls)
- | Pexp_newtype (s, e) -> newtype ~loc ~attrs s (sub.expr sub e)
- | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me)
- | Pexp_open (ovf, lid, e) ->
- open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e)
- | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x)
-end
+(** used for cases like [%sexp] *)
+let gen_expression ({Asttypes.txt ; loc}) typ =
+ let txt = Ext_string.tail_from txt (String.length Literals.bs_deriving_dot) in
+ match (Ast_payload.table_dispatch !derive_table
+ ({txt ; loc}, None)).expression_gen with
+ | None ->
+ Bs_syntaxerr.err loc (Unregistered txt)
-module P = struct
- (* Patterns *)
+ | Some f -> f typ
- let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} =
- let open Pat in
- let loc = sub.location sub loc in
- let attrs = sub.attributes sub attrs in
- match desc with
- | Ppat_any -> any ~loc ~attrs ()
- | Ppat_var s -> var ~loc ~attrs (map_loc sub s)
- | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s)
- | Ppat_constant c -> constant ~loc ~attrs c
- | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2
- | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl)
- | Ppat_construct (l, p) ->
- construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p)
- | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p)
- | Ppat_record (lpl, cf) ->
- record ~loc ~attrs
- (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf
- | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl)
- | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2)
- | Ppat_constraint (p, t) ->
- constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t)
- | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s)
- | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p)
- | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s)
- | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p)
- | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x)
+open Ast_helper
+let gen_structure_signature
+ loc
+ (tdcls : tdcls)
+ (action : Ast_payload.action)
+ (explicit_nonrec : bool) =
+ let derive_table = !derive_table in
+ let u =
+ Ast_payload.table_dispatch derive_table action in
+
+ let a = u.structure_gen tdcls explicit_nonrec in
+ let b = u.signature_gen tdcls explicit_nonrec in
+ Str.include_ ~loc
+ (Incl.mk ~loc
+ (Mod.constraint_ ~loc
+ (Mod.structure ~loc a)
+ (Mty.signature ~loc b )
+ )
+ )
end
+module Ast_derive_util : sig
+#1 "ast_derive_util.mli"
+(* Copyright (C) 2017 Authors of BuckleScript
+ *
+ * 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 CE = struct
- (* Value expressions for the class language *)
+(** Given a type declaration, extaract the type expression, mostly
+ used in code gen later
+ *)
+ val core_type_of_type_declaration :
+ Parsetree.type_declaration -> Parsetree.core_type
- let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} =
- let open Cl in
- let loc = sub.location sub loc in
- let attrs = sub.attributes sub attrs in
- match desc with
- | Pcl_constr (lid, tys) ->
- constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys)
- | Pcl_structure s ->
- structure ~loc ~attrs (sub.class_structure sub s)
- | Pcl_fun (lab, e, p, ce) ->
- fun_ ~loc ~attrs lab
- (map_opt (sub.expr sub) e)
- (sub.pat sub p)
- (sub.class_expr sub ce)
- | Pcl_apply (ce, l) ->
- apply ~loc ~attrs (sub.class_expr sub ce)
- (List.map (map_snd (sub.expr sub)) l)
- | Pcl_let (r, vbs, ce) ->
-(* XXXX *)
- (* let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs)
- (sub.class_expr sub ce) *)
- let_ ~loc ~attrs r
- ((if r = Recursive then sub.value_bindings_rec else sub.value_bindings)
- sub vbs)
- (sub.class_expr sub ce)
-(* XXXX *)
- | Pcl_constraint (ce, ct) ->
- constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct)
- | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x)
+val new_type_of_type_declaration :
+ Parsetree.type_declaration ->
+ string ->
+ Parsetree.core_type * Parsetree.type_declaration
- let map_kind sub = function
- | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e)
- | Cfk_virtual t -> Cfk_virtual (sub.typ sub t)
+val lift_string_list_to_array : string list -> Parsetree.expression
+val lift_int : int -> Parsetree.expression
+val lift_int_list_to_array : int list -> Parsetree.expression
+val mk_fun :
+ loc:Location.t ->
+ Parsetree.core_type ->
+ string -> Parsetree.expression -> Parsetree.expression
+val destruct_label_declarations :
+ loc:Location.t ->
+ string ->
+ Parsetree.label_declaration list ->
+ (Parsetree.core_type * Parsetree.expression) list * string list
- let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} =
- let open Cf in
- let loc = sub.location sub loc in
- let attrs = sub.attributes sub attrs in
- match desc with
- | Pcf_inherit (o, ce, s) -> inherit_ ~loc ~attrs o (sub.class_expr sub ce) s
- | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k)
- | Pcf_method (s, p, k) ->
- method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k)
- | Pcf_constraint (t1, t2) ->
- constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2)
- | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e)
- | Pcf_attribute x -> attribute ~loc (sub.attribute sub x)
- | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x)
+val notApplicable:
+ Location.t ->
+ string ->
+ unit
- let map_structure sub {pcstr_self; pcstr_fields} =
- {
- pcstr_self = sub.pat sub pcstr_self;
- pcstr_fields = List.map (sub.class_field sub) pcstr_fields;
- }
+val invalid_config : Parsetree.expression -> 'a
+end = struct
+#1 "ast_derive_util.ml"
+(* 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 class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr;
- pci_loc; pci_attributes} =
- Ci.mk
- ~virt:pci_virt
- ~params:(List.map (map_fst (sub.typ sub)) pl)
- (map_loc sub pci_name)
- (f pci_expr)
- ~loc:(sub.location sub pci_loc)
- ~attrs:(sub.attributes sub pci_attributes)
-end
+open Ast_helper
-(* Now, a generic AST mapper, to be extended to cover all kinds and
- cases of the OCaml grammar. The default behavior of the mapper is
- the identity. *)
+let core_type_of_type_declaration
+ (tdcl : Parsetree.type_declaration) =
+ match tdcl with
+ | {ptype_name = {txt ; loc};
+ ptype_params ;
+ } ->
+ Typ.constr
+ {txt = Lident txt ; loc}
+ (Ext_list.map fst ptype_params)
-let default_mapper =
- {
- structure = (fun this l -> List.map (this.structure_item this) l);
- structure_item = M.map_structure_item;
- module_expr = M.map;
- signature = (fun this l -> List.map (this.signature_item this) l);
- signature_item = MT.map_signature_item;
- module_type = MT.map;
- with_constraint = MT.map_with_constraint;
- class_declaration =
- (fun this -> CE.class_infos this (this.class_expr this));
- class_expr = CE.map;
- class_field = CE.map_field;
- class_structure = CE.map_structure;
- class_type = CT.map;
- class_type_field = CT.map_field;
- class_signature = CT.map_signature;
- class_type_declaration =
- (fun this -> CE.class_infos this (this.class_type this));
- class_description =
- (fun this -> CE.class_infos this (this.class_type this));
- type_declaration = T.map_type_declaration;
- type_kind = T.map_type_kind;
- typ = T.map;
- type_extension = T.map_type_extension;
- extension_constructor = T.map_extension_constructor;
- value_description =
- (fun this {pval_name; pval_type; pval_prim; pval_loc;
- pval_attributes} ->
- Val.mk
- (map_loc this pval_name)
- (this.typ this pval_type)
- ~attrs:(this.attributes this pval_attributes)
- ~loc:(this.location this pval_loc)
- ~prim:pval_prim
- );
+let new_type_of_type_declaration
+ (tdcl : Parsetree.type_declaration) newName =
+ match tdcl with
+ | {ptype_name = { loc};
+ ptype_params ;
+ } ->
+ (Typ.constr
+ {txt = Lident newName ; loc}
+ (Ext_list.map fst ptype_params),
+ { Parsetree.ptype_params = tdcl.ptype_params;
+ ptype_name = {txt = newName;loc};
+ ptype_kind = Ptype_abstract;
+ ptype_attributes = [];
+ ptype_loc = tdcl.ptype_loc;
+ ptype_cstrs = []; ptype_private = Public; ptype_manifest = None}
+ )
- pat = P.map;
- expr = E.map;
+
+let lift_string_list_to_array (labels : string list) =
+ Exp.array
+ (Ext_list.map (fun s -> Exp.constant (Const_string (s, None)))
+ labels)
- module_declaration =
- (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} ->
- Md.mk
- (map_loc this pmd_name)
- (this.module_type this pmd_type)
- ~attrs:(this.attributes this pmd_attributes)
- ~loc:(this.location this pmd_loc)
- );
+let lift_int i = Exp.constant (Const_int i)
+let lift_int_list_to_array (labels : int list) =
+ Exp.array (Ext_list.map lift_int labels)
- module_type_declaration =
- (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} ->
- Mtd.mk
- (map_loc this pmtd_name)
- ?typ:(map_opt (this.module_type this) pmtd_type)
- ~attrs:(this.attributes this pmtd_attributes)
- ~loc:(this.location this pmtd_loc)
- );
- module_binding =
- (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} ->
- Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr)
- ~attrs:(this.attributes this pmb_attributes)
- ~loc:(this.location this pmb_loc)
- );
+let mk_fun ~loc (typ : Parsetree.core_type)
+ (value : string) body
+ : Parsetree.expression =
+ Exp.fun_
+ "" None
+ (Pat.constraint_ (Pat.var {txt = value ; loc}) typ)
+ body
+let destruct_label_declarations ~loc
+ (arg_name : string)
+ (labels : Parsetree.label_declaration list) :
+ (Parsetree.core_type * Parsetree.expression) list * string list
+ =
+ Ext_list.fold_right
+ (fun ({pld_name = {txt}; pld_type} : Parsetree.label_declaration)
+ (core_type_exps, labels) ->
+ ((pld_type,
+ Exp.field (Exp.ident {txt = Lident arg_name ; loc})
+ {txt = Lident txt ; loc}) :: core_type_exps),
+ txt :: labels
+ ) labels ([], [])
- open_description =
- (fun this {popen_lid; popen_override; popen_attributes; popen_loc} ->
- Opn.mk (map_loc this popen_lid)
- ~override:popen_override
- ~loc:(this.location this popen_loc)
- ~attrs:(this.attributes this popen_attributes)
- );
+let notApplicable
+ loc derivingName =
+ Location.prerr_warning
+ loc
+ (Warnings.Bs_derive_warning ( derivingName ^ " not applicable to this type"))
+
+let invalid_config (config : Parsetree.expression) =
+ Location.raise_errorf ~loc:config.pexp_loc "such configuration is not supported"
+
+end
+module Ast_derive_abstract : sig
+#1 "ast_derive_abstract.mli"
+(* Copyright (C) 2017 Authors of BuckleScript
+ *
+ * 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 handleTdclsInStr :
+ Parsetree.type_declaration list -> Parsetree.structure
- include_description =
- (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
- Incl.mk (this.module_type this pincl_mod)
- ~loc:(this.location this pincl_loc)
- ~attrs:(this.attributes this pincl_attributes)
- );
+val handleTdclsInSig:
+ Parsetree.type_declaration list -> Parsetree.signature
+end = struct
+#1 "ast_derive_abstract.ml"
+(* Copyright (C) 2017 Authors of BuckleScript
+ *
+ * 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. *)
- include_declaration =
- (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
- Incl.mk (this.module_expr this pincl_mod)
- ~loc:(this.location this pincl_loc)
- ~attrs:(this.attributes this pincl_attributes)
- );
- value_bindings = (fun this vbs ->
- match vbs with
- | [vb] -> [ this.value_binding this vb ]
- | _ -> List.map (this.value_binding this) vbs
- );
- value_bindings_rec = (fun this vbs ->
- match vbs with
- | [vb] -> [ this.value_binding this vb ]
- | _ -> List.map (this.value_binding this) vbs
- );
- value_binding =
- (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} ->
- Vb.mk
- (this.pat this pvb_pat)
- (this.expr this pvb_expr)
- ~loc:(this.location this pvb_loc)
- ~attrs:(this.attributes this pvb_attributes)
- );
+let derivingName = "abstract"
+module U = Ast_derive_util
+open Ast_helper
+type tdcls = Parsetree.type_declaration list
+let handle_config (config : Parsetree.expression option) =
+ match config with
+ | Some config ->
+ U.invalid_config config
+ | None -> ()
- constructor_declaration =
- (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} ->
- Type.constructor
- (map_loc this pcd_name)
- ~args:(List.map (this.typ this) pcd_args)
- ?res:(map_opt (this.typ this) pcd_res)
- ~loc:(this.location this pcd_loc)
- ~attrs:(this.attributes this pcd_attributes)
- );
+(* see #2337
+ TODO: relax it to allow (int -> int [@bs])
+*)
+let rec checkNotFunciton (ty : Parsetree.core_type) =
+ match ty.ptyp_desc with
+ | Ptyp_poly (_,ty) -> checkNotFunciton ty
+ | Ptyp_alias (ty,_) -> checkNotFunciton ty
+ | Ptyp_arrow _ ->
+ Location.raise_errorf
+ ~loc:ty.ptyp_loc
+ "syntactic function type is not allowed when working with abstract bs.deriving, create a named type as work around"
+ | Ptyp_any
+ | Ptyp_var _
+ | Ptyp_tuple _
+ | Ptyp_constr _
+ | Ptyp_object _
+ | Ptyp_class _
+ | Ptyp_variant _
+ | Ptyp_package _
+ | Ptyp_extension _ -> ()
+let handleTdcl (tdcl : Parsetree.type_declaration) =
+ let core_type = U.core_type_of_type_declaration tdcl in
+ let loc = tdcl.ptype_loc in
+ let name = tdcl.ptype_name.txt in
+ let newTdcl = {
+ tdcl with
+ ptype_kind = Ptype_abstract;
+ ptype_attributes = [];
+ (* avoid non-terminating*)
+ } in
+ match tdcl.ptype_kind with
+ | Ptype_record label_declarations ->
+ let ty =
+ Ext_list.fold_right (fun (label_declaration : Parsetree.label_declaration) acc ->
+ Typ.arrow
+ label_declaration.pld_name.txt label_declaration.pld_type acc
+ ) label_declarations core_type in
+ let setter_accessor =
+ Ext_list.fold_right (fun (x: Parsetree.label_declaration) acc ->
+ let pld_name = x.pld_name.txt in
+ let pld_loc = x.pld_name.loc in
+ let pld_type = x.pld_type in
+ let () = checkNotFunciton pld_type in
+ let setter =
+ Val.mk
+ {loc = pld_loc; txt = pld_name}
+ ~attrs:[Ast_attributes.bs_get]
+ ~prim:[pld_name]
+ (Typ.arrow "" core_type pld_type) :: acc in
+ match x.pld_mutable with
+ | Mutable ->
+ Val.mk
+ {loc = pld_loc; txt = pld_name ^ "Set"}
+ ~attrs:[Ast_attributes.bs_set]
+ ~prim:[pld_name]
+ (Typ.arrow "" core_type (Typ.arrow "" pld_type (Ast_literal.type_unit ()))) :: setter
+ | Immutable -> setter
+ ) label_declarations []
+ in
- label_declaration =
- (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} ->
- Type.field
- (map_loc this pld_name)
- (this.typ this pld_type)
- ~mut:pld_mutable
- ~loc:(this.location this pld_loc)
- ~attrs:(this.attributes this pld_attributes)
- );
+ newTdcl,
+ (match tdcl.ptype_private with
+ | Private -> setter_accessor
+ | Public ->
+ let maker =
+ Val.mk {loc; txt = name}
+ ~attrs:[Ast_attributes.bs_obj]
+ ~prim:[""] ty in
+ (maker :: setter_accessor))
- cases = (fun this l -> List.map (this.case this) l);
- case =
- (fun this {pc_lhs; pc_guard; pc_rhs} ->
- {
- pc_lhs = this.pat this pc_lhs;
- pc_guard = map_opt (this.expr this) pc_guard;
- pc_rhs = this.expr this pc_rhs;
- }
- );
+ | Ptype_abstract
+ | Ptype_variant _
+ | Ptype_open ->
+ (* Looks obvious that it does not make sense to warn *)
+ (* U.notApplicable tdcl.ptype_loc derivingName; *)
+ tdcl, []
+let handleTdclsInStr tdcls =
+ let tdcls, code =
+ List.fold_right (fun tdcl (tdcls, sts) ->
+ match handleTdcl tdcl with
+ ntdcl, value_descriptions ->
+ ntdcl::tdcls,
+ Ext_list.map_append (fun x -> Str.primitive x) value_descriptions sts
+ ) tdcls ([],[]) in
+ Str.type_ tdcls :: code
+(* still need perform transformation for non-abstract type*)
- location = (fun this l -> l);
+let handleTdclsInSig tdcls =
+ let tdcls, code =
+ List.fold_right (fun tdcl (tdcls, sts) ->
+ match handleTdcl tdcl with
+ ntdcl, value_descriptions ->
+ ntdcl::tdcls,
+ Ext_list.map_append (fun x -> Sig.value x) value_descriptions sts
- extension = (fun this (s, e) -> (map_loc this s, this.payload this e));
- attribute = (fun this (s, e) -> (map_loc this s, this.payload this e));
- attributes = (fun this l -> List.map (this.attribute this) l);
- payload =
- (fun this -> function
- | PStr x -> PStr (this.structure this x)
- | PTyp x -> PTyp (this.typ this x)
- | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g)
- );
- }
+ ) tdcls ([],[]) in
+ Sig.type_ tdcls :: code
end
-module External_process : sig
-#1 "external_process.mli"
-(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+module Ast_derive_js_mapper : sig
+#1 "ast_derive_js_mapper.mli"
+(* Copyright (C) 2017 Authors of BuckleScript
*
* 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
@@ -108904,39 +109696,10 @@ module External_process : sig
-
-
-(**
- [handle_attributes_as_string
- loc pval_name.txt pval_type pval_attributes pval_prim]
- [pval_name.txt] is the name of identifier
- [pval_prim] is the name of string literal
-
- return value is of [pval_type, pval_prims, new_attrs]
-*)
-val handle_attributes_as_string :
- Bs_loc.t ->
- string ->
- Ast_core_type.t ->
- Ast_attributes.t ->
- string ->
- Ast_core_type.t * string list * Ast_attributes.t
-
-
-
-
-(** [pval_prim_of_labels labels]
- return [pval_prims] for FFI, it is specialized for
- external object which is used in
- {[ [%obj { x = 2; y = 1} ] ]}
-*)
-val pval_prim_of_labels : string Asttypes.loc list -> string list
-
-
-
+val init : unit -> unit
end = struct
-#1 "external_process.ml"
-(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+#1 "ast_derive_js_mapper.ml"
+(* Copyright (C) 2017 Authors of BuckleScript
*
* 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
@@ -108960,979 +109723,1247 @@ end = struct
* 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 U = Ast_derive_util
+type tdcls = Parsetree.type_declaration list
-[@@@ocaml.warning "+9"]
-
-
-
-let variant_can_bs_unwrap_fields row_fields =
- let validity =
- List.fold_left
- begin fun st row ->
- match st, row with
- | (* we've seen no fields or only valid fields so far *)
- (`No_fields | `Valid_fields),
- (* and this field has one constructor arg that we can unwrap to *)
- Parsetree.Rtag (label, attrs, false, ([ _ ]))
- ->
- `Valid_fields
- | (* otherwise, this field or a previous field was invalid *)
- _ ->
- `Invalid_field
- end
- `No_fields
- row_fields
- in
- match validity with
- | `Valid_fields -> true
- | `No_fields
- | `Invalid_field -> false
-
-
-(** Given the type of argument, process its [bs.] attribute and new type,
- The new type is currently used to reconstruct the external type
- and result type in [@@bs.obj]
- They are not the same though, for example
- {[
- external f : hi:([ `hi | `lo ] [@bs.string]) -> unit -> _ = "" [@@bs.obj]
- ]}
- The result type would be [ hi:string ]
-*)
-let get_arg_type ~nolabel optional
- (ptyp : Ast_core_type.t) :
- External_arg_spec.attr * Ast_core_type.t =
- let ptyp = if optional then Ast_core_type.extract_option_type_exn ptyp else ptyp in
- if Ast_core_type.is_any ptyp then (* (_[@bs.as ])*)
- if optional then
- Bs_syntaxerr.err ptyp.ptyp_loc Invalid_underscore_type_in_external
- else begin
- let ptyp_attrs =
- ptyp.Parsetree.ptyp_attributes
- in
- let result =
- Ast_attributes.iter_process_bs_string_or_int_as ptyp_attrs
- in
- (* when ppx start dropping attributes
- we should warn, there is a trade off whether
- we should warn dropped non bs attribute or not
- *)
- Bs_ast_invariant.warn_unused_attributes ptyp_attrs;
- match result with
- | None ->
- Bs_syntaxerr.err ptyp.ptyp_loc Invalid_underscore_type_in_external
-
- | Some (`Int i) ->
- Arg_cst(External_arg_spec.cst_int i), Ast_literal.type_int ~loc:ptyp.ptyp_loc ()
- | Some (`Str i)->
- Arg_cst (External_arg_spec.cst_string i), Ast_literal.type_string ~loc:ptyp.ptyp_loc ()
- | Some (`Json_str s) ->
- Arg_cst (External_arg_spec.cst_json ptyp.ptyp_loc s),
- Ast_literal.type_string ~loc:ptyp.ptyp_loc ()
-
- end
- else (* ([`a|`b] [@bs.string]) *)
- let ptyp_desc = ptyp.ptyp_desc in
- match Ast_attributes.process_bs_string_int_unwrap_uncurry ptyp.ptyp_attributes with
- | (`String, ptyp_attributes)
- ->
- begin match ptyp_desc with
- | Ptyp_variant ( row_fields, Closed, None)
- ->
- let attr =
- Ast_polyvar.map_row_fields_into_strings ptyp.ptyp_loc row_fields in
- attr,
- {ptyp with
- ptyp_attributes
- }
- | _ ->
- Bs_syntaxerr.err ptyp.ptyp_loc Invalid_bs_string_type
- end
- | (`Ignore, ptyp_attributes) ->
- (Ignore, {ptyp with ptyp_attributes})
- | (`Int , ptyp_attributes) ->
- begin match ptyp_desc with
- | Ptyp_variant ( row_fields, Closed, None) ->
- let int_lists =
- Ast_polyvar.map_row_fields_into_ints ptyp.ptyp_loc row_fields in
- Int int_lists ,
- {ptyp with
- ptyp_attributes
- }
- | _ -> Bs_syntaxerr.err ptyp.ptyp_loc Invalid_bs_int_type
- end
- | (`Unwrap, ptyp_attributes) ->
-
- begin match ptyp_desc with
- | (Ptyp_variant (row_fields, Closed, _) as ptyp_desc)
- when variant_can_bs_unwrap_fields row_fields ->
- Unwrap, {ptyp with ptyp_desc; ptyp_attributes}
- | _ ->
- Bs_syntaxerr.err ptyp.ptyp_loc Invalid_bs_unwrap_type
- end
- | (`Uncurry opt_arity, ptyp_attributes) ->
- let real_arity = Ast_core_type.get_uncurry_arity ptyp in
- (begin match opt_arity, real_arity with
- | Some arity, `Not_function ->
- Fn_uncurry_arity arity
- | None, `Not_function ->
- Bs_syntaxerr.err ptyp.ptyp_loc Canot_infer_arity_by_syntax
- | None, `Arity arity ->
- Fn_uncurry_arity arity
- | Some arity, `Arity n ->
- if n <> arity then
- Bs_syntaxerr.err ptyp.ptyp_loc (Inconsistent_arity (arity,n))
- else Fn_uncurry_arity arity
-
- end, {ptyp with ptyp_attributes})
- | (`Nothing, ptyp_attributes) ->
- begin match ptyp_desc with
- | Ptyp_constr ({txt = Lident "bool"; _}, [])
- ->
- Bs_warnings.prerr_bs_ffi_warning ptyp.ptyp_loc Unsafe_ffi_bool_type;
- Nothing
- | Ptyp_constr ({txt = Lident "unit"; _}, [])
- -> if nolabel then Extern_unit else Nothing
- | Ptyp_constr ({txt = Lident "array"; _}, [_])
- -> Array
- | Ptyp_variant _ ->
- Bs_warnings.prerr_bs_ffi_warning ptyp.ptyp_loc Unsafe_poly_variant_type;
- Nothing
- | _ ->
- Nothing
- end, ptyp
-
-
-
-(**
- [@@bs.module "react"]
- [@@bs.module "react"]
- ---
- [@@bs.module "@" "react"]
- [@@bs.module "@" "react"]
-
- They should have the same module name
-
- TODO: we should emit an warning if we bind
- two external files to the same module name
-*)
-type bundle_source =
- [`Nm_payload of string (* from payload [@@bs.val "xx" ]*)
- |`Nm_external of string (* from "" in external *)
- | `Nm_val of string (* from function name *)
- ]
-
-let string_of_bundle_source (x : bundle_source) =
- match x with
- | `Nm_payload x
- | `Nm_external x
- | `Nm_val x -> x
-type name_source =
- [ bundle_source
- | `Nm_na
-
- ]
-
-
-
-
-type st =
- { val_name : name_source;
- external_module_name : External_ffi_types.external_module_name option;
- module_as_val : External_ffi_types.external_module_name option;
- val_send : name_source ;
- val_send_pipe : Ast_core_type.t option;
- splice : bool ; (* mutable *)
- scopes : string list ;
- set_index : bool; (* mutable *)
- get_index : bool;
- new_name : name_source ;
- call_name : name_source ;
- set_name : name_source ;
- get_name : name_source ;
-
- mk_obj : bool ;
- return_wrapper : External_ffi_types.return_wrapper ;
-
- }
-
-let init_st =
- {
- val_name = `Nm_na;
- external_module_name = None ;
- module_as_val = None;
- val_send = `Nm_na;
- val_send_pipe = None;
- splice = false;
- scopes = [];
- set_index = false;
- get_index = false;
- new_name = `Nm_na;
- call_name = `Nm_na;
- set_name = `Nm_na ;
- get_name = `Nm_na ;
- mk_obj = false ;
- return_wrapper = Return_unset;
+let js_field (o : Parsetree.expression) m =
+ Exp.apply
+ (Exp.ident {txt = Lident "##"; loc = o.pexp_loc})
+ [
+ "",o;
+ "", Exp.ident m
+ ]
+let const_int i = Exp.constant (Const_int i)
+let const_string s = Exp.constant (Const_string (s,None))
- }
+let handle_config (config : Parsetree.expression option) =
+ match config with
+ | Some config ->
+ (match config.pexp_desc with
+ | Pexp_record (
+ [
+ {txt = Lident "newType"},
+ {pexp_desc =
+ (Pexp_construct
+ (
+ {txt =
+ Lident ("true"
+ | "false"
+ as x)}, None)
+ | Pexp_ident {txt = Lident ("newType" as x)}
+ )
+ }
+ ],None)
+ -> not (x = "false")
+ | Pexp_ident {txt = Lident ("newType")}
+ -> true
+ | _ -> U.invalid_config config)
+ | None -> false
+let noloc = Location.none
+(* [eraseType] will be instrumented, be careful about the name conflict*)
+let eraseTypeLit = "jsMapperEraseType"
+let eraseTypeExp = Exp.ident {loc = noloc; txt = Lident eraseTypeLit}
+let eraseType x =
+ Exp.apply eraseTypeExp ["", x]
+let eraseTypeStr =
+ let any = Typ.any () in
+ Str.primitive
+ (Val.mk ~prim:["%identity"] {loc = noloc; txt = eraseTypeLit}
+ (Typ.arrow "" any any)
+ )
+let app2 f arg1 arg2 =
+ Exp.apply f ["",arg1; "", arg2]
+let app3 f arg1 arg2 arg3 =
+ Exp.apply f ["", arg1; "", arg2; "", arg3]
+let (<=~) a b =
+ app2 (Exp.ident {loc = noloc; txt = Lident "<="}) a b
+let (-~) a b =
+ app2 (Exp.ident {loc = noloc; txt = Ldot(Lident "Pervasives","-")})
+ a b
+let (+~) a b =
+ app2 (Exp.ident {loc = noloc; txt = Ldot(Lident "Pervasives","+")})
+ a b
+let (&&~) a b =
+ app2 (Exp.ident {loc = noloc; txt = Ldot(Lident "Pervasives","&&")})
+ a b
+let (->~) a b = Typ.arrow "" a b
+let jsMapperRt =
+ Longident.Ldot (Lident "Js", "MapperRt")
+let search upper polyvar array =
+ app3
+ (Exp.ident ({loc = noloc;
+ txt = Longident.Ldot (jsMapperRt,"binarySearch") })
+ )
+ upper
+ (eraseType polyvar)
+ array
+let revSearch len constantArray exp =
+ app3
+ (Exp.ident
+ {loc= noloc;
+ txt = Longident.Ldot (jsMapperRt, "revSearch")})
+ len
+ constantArray
+ exp
-let process_external_attributes
- no_arguments
- (prim_name_or_pval_prim: [< bundle_source ] as 'a)
- pval_prim
- (prim_attributes : Ast_attributes.t) : _ * Ast_attributes.t =
+let revSearchAssert len constantArray exp =
+ app3
+ (Exp.ident
+ {loc= noloc;
+ txt = Longident.Ldot (jsMapperRt, "revSearchAssert")})
+ len
+ constantArray
+ exp
- (* shared by `[@@bs.val]`, `[@@bs.send]`,
- `[@@bs.set]`, `[@@bs.get]` , `[@@bs.new]`
- `[@@bs.send.pipe]` does not use it
- *)
- let name_from_payload_or_prim ~loc (payload : Parsetree.payload) : name_source =
- match payload with
- | PStr [] ->
- (prim_name_or_pval_prim :> name_source)
- (* It is okay to have [@@bs.val] without payload *)
- | _ ->
- begin match Ast_payload.is_single_string payload with
- | Some (val_name, _) -> `Nm_payload val_name
- | None ->
- Location.raise_errorf ~loc "Invalid payload"
- end
+let toInt exp array =
+ app2
+ (Exp.ident
+ { loc=noloc;
+ txt = Longident.Ldot (jsMapperRt, "toInt")})
+ (eraseType exp)
+ array
+let fromInt len array exp =
+ app3
+ (Exp.ident
+ {loc = noloc;
+ txt = Longident.Ldot (jsMapperRt,"fromInt")})
+ len
+ array
+ exp
- in
- List.fold_left
- (fun (st, attrs)
- (({txt ; loc}, payload) as attr : Ast_attributes.attr)
- ->
- if Ext_string.starts_with txt "bs." then
- begin match txt with
- | "bs.val" ->
- if no_arguments then
- {st with val_name = name_from_payload_or_prim ~loc payload}
- else
- {st with call_name = name_from_payload_or_prim ~loc payload}
+let fromIntAssert len array exp =
+ app3
+ (Exp.ident
+ {loc = noloc;
+ txt = Longident.Ldot (jsMapperRt,"fromIntAssert")})
+ len
+ array
+ exp
- | "bs.module" ->
- begin match Ast_payload.assert_strings loc payload with
- | [bundle] ->
- {st with external_module_name =
- Some {bundle; module_bind_name = Phint_nothing}}
- | [bundle;bind_name] ->
- {st with external_module_name =
- Some {bundle; module_bind_name = Phint_name bind_name}}
- | [] ->
- { st with
- module_as_val =
- Some
- { bundle =
- string_of_bundle_source
- (prim_name_or_pval_prim :> bundle_source) ;
- module_bind_name = Phint_nothing}
- }
- | _ ->
- Bs_syntaxerr.err loc Illegal_attribute
- end
- | "bs.scope" ->
- begin match Ast_payload.assert_strings loc payload with
- | [] ->
- Bs_syntaxerr.err loc Illegal_attribute
- (* We need err on empty scope, so we can tell the difference
- between unset/set
- *)
- | scopes -> { st with scopes = scopes }
- end
- | "bs.splice" -> {st with splice = true}
- | "bs.send" ->
- { st with val_send = name_from_payload_or_prim ~loc payload}
- | "bs.send.pipe"
- ->
- { st with val_send_pipe = Some (Ast_payload.as_core_type loc payload)}
- | "bs.set" ->
- {st with set_name = name_from_payload_or_prim ~loc payload}
- | "bs.get" -> {st with get_name = name_from_payload_or_prim ~loc payload}
- | "bs.new" -> {st with new_name = name_from_payload_or_prim ~loc payload}
- | "bs.set_index" -> {st with set_index = true}
- | "bs.get_index"-> {st with get_index = true}
- | "bs.obj" -> {st with mk_obj = true}
- | "bs.return" ->
- let aux loc txt : External_ffi_types.return_wrapper =
- begin match txt with
- | "undefined_to_opt" -> Return_undefined_to_opt
- | "null_to_opt" -> Return_null_to_opt
- | "nullable"
- | "null_undefined_to_opt" -> Return_null_undefined_to_opt
- | "identity" -> Return_identity
- | _ ->
- Bs_syntaxerr.err loc Not_supported_directive_in_bs_return
- end in
- let actions =
- Ast_payload.ident_or_record_as_config loc payload
- in
- begin match actions with
- | [ ({txt; _ },None) ] ->
- { st with return_wrapper = aux loc txt}
- | _ ->
- Bs_syntaxerr.err loc Not_supported_directive_in_bs_return
- end
- | _ -> (Location.prerr_warning loc (Bs_unused_attribute txt); st)
- end, attrs
- else (st , attr :: attrs)
+let assertExp e =
+ Exp.extension
+ ({Asttypes.loc = noloc; txt = "assert"},
+ (PStr
+ [Str.eval e ]
+ )
)
- (init_st, []) prim_attributes
-
-
-let rec has_bs_uncurry (attrs : Ast_attributes.t) =
- match attrs with
- | ({txt = "bs.uncurry"; _ }, _) :: attrs ->
- true
- | _ :: attrs -> has_bs_uncurry attrs
- | [] -> false
+let derivingName = "jsConverter"
+(* let notApplicable loc =
+ Location.prerr_warning
+ loc
+ (Warnings.Bs_derive_warning ( derivingName ^ " not applicable to this type")) *)
-let check_return_wrapper
- loc (wrapper : External_ffi_types.return_wrapper)
- result_type =
- match wrapper with
- | Return_identity -> wrapper
- | Return_unset ->
- if Ast_core_type.is_unit result_type then
- Return_replaced_with_unit
- else if Ast_core_type.is_user_bool result_type then
- Return_to_ocaml_bool
- else
- wrapper
- | Return_undefined_to_opt
- | Return_null_to_opt
- | Return_null_undefined_to_opt
- ->
- if Ast_core_type.is_user_option result_type then
- wrapper
- else
- Bs_syntaxerr.err loc Expect_opt_in_bs_return_to_opt
- | Return_replaced_with_unit
- | Return_to_ocaml_bool ->
- assert false (* Not going to happen from user input*)
+let init () =
+ Ast_derive.register
+ derivingName
+ (fun ( x : Parsetree.expression option) ->
+ let createType = handle_config x in
+ {
+ structure_gen = (fun (tdcls : tdcls) _ ->
+ let handle_tdcl (tdcl: Parsetree.type_declaration) =
+ let core_type = U.core_type_of_type_declaration tdcl
+ in
+ let name = tdcl.ptype_name.txt in
+ let toJs = name ^ "ToJs" in
+ let fromJs = name ^ "FromJs" in
+ let constantArray = "jsMapperConstantArray" in
+ let loc = tdcl.ptype_loc in
+ let patToJs = {Asttypes.loc; txt = toJs} in
+ let patFromJs = {Asttypes.loc; txt = fromJs} in
+ let param = "param" in
+ let ident_param = {Asttypes.txt = Longident.Lident param; loc} in
+ let pat_param = {Asttypes.loc; txt = param} in
+ let exp_param = Exp.ident ident_param in
+ let newType,newTdcl =
+ U.new_type_of_type_declaration tdcl ("abs_" ^ name) in
+ let newTypeStr = Str.type_ [newTdcl] in
+ let toJsBody body =
+ Ast_comb.single_non_rec_value patToJs
+ (Exp.fun_ "" None (Pat.constraint_ (Pat.var pat_param) core_type)
+ body )
+ in
+ let (+>) a ty =
+ Exp.constraint_ (eraseType a) ty in
+ let (+:) a ty =
+ eraseType (Exp.constraint_ a ty) in
+ let coerceResultToNewType e =
+ if createType then
+ e +> newType
+ else e
+ in
+ match tdcl.ptype_kind with
+ | Ptype_record label_declarations ->
+ let exp =
+ coerceResultToNewType
+ (Exp.extension
+ (
+ {Asttypes.loc; txt = "bs.obj"},
+ (PStr
+ [Str.eval
+ (Exp.record
+ (List.map
+ (fun ({pld_name = {loc; txt } } : Parsetree.label_declaration) ->
+ let label =
+ {Asttypes.loc; txt = Longident.Lident txt } in
+ label,Exp.field exp_param label
+ ) label_declarations) None)]))) in
+ let toJs =
+ toJsBody exp
+ in
+ let obj_exp =
+ Exp.record
+ (List.map
+ (fun ({pld_name = {loc; txt } } : Parsetree.label_declaration) ->
+ let label =
+ {Asttypes.loc; txt = Longident.Lident txt } in
+ label,
+ js_field exp_param label
+ ) label_declarations) None in
+ let fromJs =
+ Ast_comb.single_non_rec_value patFromJs
+ (Exp.fun_ "" None (Pat.var pat_param)
+ (if createType then
+ (Exp.let_ Nonrecursive
+ [Vb.mk
+ (Pat.var pat_param)
+ (exp_param +: newType)]
+ (Exp.constraint_ obj_exp core_type) )
+ else
+ (Exp.constraint_ obj_exp core_type) ))
+ in
+ let rest =
+ [
+ toJs;
+ fromJs
+ ] in
+ if createType then eraseTypeStr:: newTypeStr :: rest else rest
+ | Ptype_abstract ->
+ (match Ast_polyvar.is_enum_polyvar tdcl with
+ | Some row_fields ->
+ let attr =
+ Ast_polyvar.map_row_fields_into_strings loc row_fields
+ in
+ let expConstantArray =
+ Exp.ident {loc; txt = Longident.Lident constantArray} in
+ begin match attr with
+ | NullString result ->
+ let result_len = List.length result in
+ let exp_len = const_int result_len in
+ let v = [
+ eraseTypeStr;
+ Ast_comb.single_non_rec_value
+ {loc; txt = constantArray}
+ (Exp.array
+ (List.map (fun (i,str) ->
+ Exp.tuple
+ [
+ const_int i;
+ const_string str
+ ]
+ ) (List.sort (fun (a,_) (b,_) -> compare (a:int) b) result)));
+ (
+ toJsBody
+ (coerceResultToNewType
+ (search
+ exp_len
+ exp_param
+ expConstantArray
+ ))
+ );
+ Ast_comb.single_non_rec_value
+ patFromJs
+ (Exp.fun_ "" None
+ (Pat.var pat_param)
+ (if createType then
+ revSearchAssert
+ exp_len
+ expConstantArray
+ (exp_param +: newType)
+ +>
+ core_type
+ else
+ revSearch
+ exp_len
+ expConstantArray
+ exp_param
+ +>
+ Ast_core_type.lift_option_type core_type
+ )
+ )
+ ] in
+ if createType then
+ newTypeStr :: v
+ else v
+ | _ -> assert false
+ end
+ | None ->
+ U.notApplicable
+ tdcl.Parsetree.ptype_loc
+ derivingName;
+ []
+ )
+ | Ptype_variant ctors ->
+ if Ast_polyvar.is_enum_constructors ctors then
+ let xs = Ast_polyvar.map_constructor_declarations_into_ints ctors in
+ match xs with
+ | `New xs ->
+ let constantArrayExp = Exp.ident {loc; txt = Lident constantArray} in
+ let exp_len = const_int (List.length ctors) in
+ let v = [
+ eraseTypeStr;
+ Ast_comb.single_non_rec_value
+ {loc; txt = constantArray}
+ (Exp.array (List.map (fun i -> const_int i) xs ))
+ ;
+ toJsBody
+ (
+ coerceResultToNewType @@
+ toInt
+ exp_param
+ constantArrayExp
+ )
+ ;
+ Ast_comb.single_non_rec_value
+ patFromJs
+ (Exp.fun_ "" None
+ (Pat.var pat_param)
+ (
+ if createType then
+ fromIntAssert
+ exp_len
+ constantArrayExp
+ (exp_param +: newType)
+ +>
+ core_type
+ else
+ fromInt
+ exp_len
+ constantArrayExp
+ exp_param
+ +>
+ Ast_core_type.lift_option_type core_type
-(** Note that the passed [type_annotation] is already processed by visitor pattern before
-*)
-let handle_attributes
- (loc : Bs_loc.t)
- (pval_prim : string )
- (type_annotation : Parsetree.core_type)
- (prim_attributes : Ast_attributes.t) (prim_name : string)
- : Ast_core_type.t * string * External_ffi_types.t * Ast_attributes.t =
- (** sanity check here
- {[ int -> int -> (int -> int -> int [@bs.uncurry])]}
- It does not make sense
- *)
- if has_bs_uncurry type_annotation.Parsetree.ptyp_attributes then
- begin
- Location.raise_errorf
- ~loc "[@@bs.uncurry] can not be applied to the whole definition"
- end;
+ )
+ )
+ ] in
+ if createType then newTypeStr :: v else v
+ | `Offset offset ->
+ let v =
+ [ eraseTypeStr;
+ toJsBody (
+ coerceResultToNewType
+ (eraseType exp_param +~ const_int offset)
+ )
+ ;
+ let len = List.length ctors in
+ let range_low = const_int (offset + 0) in
+ let range_upper = const_int (offset + len - 1) in
- let prim_name_or_pval_prim =
- if String.length prim_name = 0 then `Nm_val pval_prim
- else `Nm_external prim_name (* need check name *)
- in
- let result_type, arg_types_ty =
- Ast_core_type.list_of_arrow type_annotation in
- if has_bs_uncurry result_type.ptyp_attributes then
- begin
- Location.raise_errorf
- ~loc:result_type.ptyp_loc
- "[@@bs.uncurry] can not be applied to tailed position"
- end ;
- let (st, left_attrs) =
- process_external_attributes
- (arg_types_ty = [])
- prim_name_or_pval_prim pval_prim prim_attributes in
+ Ast_comb.single_non_rec_value
+ {loc ; txt = fromJs}
+ (Exp.fun_ "" None
+ (Pat.var pat_param)
+ (if createType then
+ (Exp.let_ Nonrecursive
+ [Vb.mk
+ (Pat.var pat_param)
+ (exp_param +: newType)
+ ]
+ (
+ Exp.sequence
+ (assertExp
+ ((exp_param <=~ range_upper) &&~ (range_low <=~ exp_param))
+ )
+ (exp_param -~ const_int offset))
+ )
+ +>
+ core_type
+ else
+ (Exp.ifthenelse
+ ( (exp_param <=~ range_upper) &&~ (range_low <=~ exp_param))
+ (Exp.construct {loc; txt = Lident "Some"}
+ ( Some (exp_param -~ const_int offset)))
+ (Some (Exp.construct {loc; txt = Lident "None"} None)))
+ +>
+ Ast_core_type.lift_option_type core_type
+ )
+ )
+ ] in
+ if createType then newTypeStr :: v else v
+ else
+ begin
+ U.notApplicable
+ tdcl.Parsetree.ptype_loc
+ derivingName;
+ []
+ end
+ | Ptype_open ->
+ U.notApplicable tdcl.Parsetree.ptype_loc
+ derivingName;
+ [] in
+ Ext_list.flat_map handle_tdcl tdcls
+ );
+ signature_gen =
+ (fun (tdcls : tdcls) _ ->
+ let handle_tdcl tdcl =
+ let core_type = U.core_type_of_type_declaration tdcl
+ in
+ let name = tdcl.ptype_name.txt in
+ let toJs = name ^ "ToJs" in
+ let fromJs = name ^ "FromJs" in
+ let loc = tdcl.ptype_loc in
+ let patToJs = {Asttypes.loc; txt = toJs} in
+ let patFromJs = {Asttypes.loc; txt = fromJs} in
+ let toJsType result =
+ Ast_comb.single_non_rec_val patToJs (Typ.arrow "" core_type result) in
+ let newType,newTdcl =
+ U.new_type_of_type_declaration tdcl ("abs_" ^ name) in
+ let newTypeStr = Sig.type_ [newTdcl] in
+ let (+?) v rest = if createType then v :: rest else rest in
+ match tdcl.ptype_kind with
+ | Ptype_record label_declarations ->
+ let objType flag =
+ Ast_comb.to_js_type loc @@
+ Typ.object_
+ (List.map
+ (fun ({pld_name = {loc; txt }; pld_type } : Parsetree.label_declaration) ->
+ txt, [], pld_type
+ ) label_declarations)
+ flag in
+ newTypeStr +?
+ [
+ toJsType (if createType then newType else objType Closed);
+ Ast_comb.single_non_rec_val patFromJs
+ ( (if createType then newType else objType Open)->~ core_type)
+ ]
- if st.mk_obj then
- begin match st with
- | {
- val_name = `Nm_na;
- external_module_name = None ;
- module_as_val = None;
- val_send = `Nm_na;
- val_send_pipe = None;
- splice = false;
- new_name = `Nm_na;
- call_name = `Nm_na;
- set_name = `Nm_na ;
- get_name = `Nm_na ;
- get_index = false ;
- return_wrapper = Return_unset ;
- set_index = false ;
- mk_obj = _;
- scopes = [];
- (* wrapper does not work with [bs.obj]
- TODO: better error message *)
- } ->
- if String.length prim_name <> 0 then
- Location.raise_errorf ~loc "[@@bs.obj] expect external names to be empty string";
- let arg_kinds, new_arg_types_ty, result_types =
- Ext_list.fold_right
- (fun (label,ty,attr,loc) ( arg_labels, arg_types, result_types) ->
- let arg_label = Ast_core_type.label_name label in
- let new_arg_label, new_arg_types, output_tys =
- match arg_label with
- | Empty ->
- let arg_type, new_ty = get_arg_type ~nolabel:true false ty in
- begin match arg_type with
- | Extern_unit ->
- External_arg_spec.empty_kind arg_type, (label,new_ty,attr,loc)::arg_types, result_types
- | _ ->
- Location.raise_errorf ~loc "expect label, optional, or unit here"
- end
- | Label name ->
- let arg_type, new_ty = get_arg_type ~nolabel:false false ty in
- begin match arg_type with
- | Ignore ->
- External_arg_spec.empty_kind arg_type,
- (label,new_ty,attr,loc)::arg_types, result_types
- | Arg_cst i ->
- let s = (Lam_methname.translate ~loc name) in
- {arg_label = External_arg_spec.label s (Some i);
- arg_type },
- arg_types, (* ignored in [arg_types], reserved in [result_types] *)
- ((name , [], new_ty) :: result_types)
- | Nothing | Array ->
- let s = (Lam_methname.translate ~loc name) in
- {arg_label = External_arg_spec.label s None ; arg_type },
- (label,new_ty,attr,loc)::arg_types,
- ((name , [], new_ty) :: result_types)
- | Int _ ->
- let s = Lam_methname.translate ~loc name in
- {arg_label = External_arg_spec.label s None; arg_type},
- (label,new_ty,attr,loc)::arg_types,
- ((name, [], Ast_literal.type_int ~loc ()) :: result_types)
- | NullString _ ->
- let s = Lam_methname.translate ~loc name in
- {arg_label = External_arg_spec.label s None; arg_type},
- (label,new_ty,attr,loc)::arg_types,
- ((name, [], Ast_literal.type_string ~loc ()) :: result_types)
- | Fn_uncurry_arity _ ->
- Location.raise_errorf ~loc
- "The combination of [@@bs.obj], [@@bs.uncurry] is not supported yet"
- | Extern_unit -> assert false
- | NonNullString _
- ->
- Location.raise_errorf ~loc
- "bs.obj label %s does not support such arg type" name
- | Unwrap ->
- Location.raise_errorf ~loc
- "bs.obj label %s does not support [@bs.unwrap] arguments" name
- end
- | Optional name ->
- let arg_type, new_ty_extract = get_arg_type ~nolabel:false true ty in
- let new_ty = Ast_core_type.lift_option_type new_ty_extract in
- begin match arg_type with
- | Ignore ->
- External_arg_spec.empty_kind arg_type,
- (label,new_ty,attr,loc)::arg_types, result_types
+ | Ptype_abstract ->
+ (match Ast_polyvar.is_enum_polyvar tdcl with
+ | Some _ ->
+ let ty1 =
+ if createType then newType else
+ (Ast_literal.type_string ()) in
+ let ty2 =
+ if createType then core_type
+ else Ast_core_type.lift_option_type core_type in
+ newTypeStr +?
+ [
+ toJsType ty1;
+ Ast_comb.single_non_rec_val
+ patFromJs
+ (ty1 ->~ ty2)
+ ]
- | Nothing | Array ->
- let s = (Lam_methname.translate ~loc name) in
- {arg_label = External_arg_spec.optional s; arg_type},
- (label,new_ty,attr,loc)::arg_types,
- ( (name, [], Ast_comb.to_undefined_type loc new_ty_extract) :: result_types)
- | Int _ ->
- let s = Lam_methname.translate ~loc name in
- {arg_label = External_arg_spec.optional s ; arg_type },
- (label,new_ty,attr,loc)::arg_types,
- ((name, [], Ast_comb.to_undefined_type loc @@ Ast_literal.type_int ~loc ()) :: result_types)
- | NullString _ ->
- let s = Lam_methname.translate ~loc name in
- {arg_label = External_arg_spec.optional s ; arg_type },
- (label,new_ty,attr,loc)::arg_types,
- ((name, [], Ast_comb.to_undefined_type loc @@ Ast_literal.type_string ~loc ()) :: result_types)
- | Arg_cst _
- ->
- Location.raise_errorf ~loc "bs.as is not supported with optional yet"
- | Fn_uncurry_arity _ ->
- Location.raise_errorf ~loc
- "The combination of [@@bs.obj], [@@bs.uncurry] is not supported yet"
- | Extern_unit -> assert false
- | NonNullString _
- ->
- Location.raise_errorf ~loc
- "bs.obj label %s does not support such arg type" name
- | Unwrap ->
- Location.raise_errorf ~loc
- "bs.obj label %s does not support [@bs.unwrap] arguments" name
- end
- in
- (
- new_arg_label::arg_labels,
- new_arg_types,
- output_tys)) arg_types_ty
- ( [], [], []) in
+ | None ->
+ U.notApplicable tdcl.Parsetree.ptype_loc
+ derivingName;
+ [])
- let result =
- if Ast_core_type.is_any result_type then
- Ast_core_type.make_obj ~loc result_types
- else
- snd @@ get_arg_type ~nolabel:true false result_type (* result type can not be labeled *)
+ | Ptype_variant ctors
+ ->
- in
- begin
- (
- Ext_list.fold_right (fun (label,ty,attrs,loc) acc ->
- Ast_helper.Typ.arrow ~loc ~attrs label ty acc
- ) new_arg_types_ty result
- ) ,
- prim_name,
- Ffi_obj_create arg_kinds,
- left_attrs
- end
+ if Ast_polyvar.is_enum_constructors ctors then
+ let ty1 =
+ if createType then newType
+ else Ast_literal.type_int() in
+ let ty2 =
+ if createType then core_type
+ else Ast_core_type.lift_option_type core_type in
+ newTypeStr +?
+ [
+ toJsType ty1;
+ Ast_comb.single_non_rec_val
+ patFromJs
+ (ty1 ->~ ty2)
+ ]
- | _ -> Location.raise_errorf ~loc "Attribute found that conflicts with [@@bs.obj]"
+ else
+ begin
+ U.notApplicable tdcl.Parsetree.ptype_loc
+ derivingName;
+ []
+ end
+ | Ptype_open ->
+ U.notApplicable tdcl.Parsetree.ptype_loc
+ derivingName;
+ [] in
+ Ext_list.flat_map handle_tdcl tdcls
- end
+ );
+ expression_gen = None
+ }
+ )
+;
- else
- let splice = st.splice in
- let arg_type_specs, new_arg_types_ty, arg_type_specs_length =
- Ext_list.fold_right
- (fun (label,ty,attr,loc) (arg_type_specs, arg_types, i) ->
- let arg_label = Ast_core_type.label_name label in
- let arg_label, arg_type, new_arg_types =
- match arg_label with
- | Optional s ->
+end
+module Ast_derive_projector : sig
+#1 "ast_derive_projector.mli"
+(* Copyright (C) 2017 Authors of BuckleScript
+ *
+ * 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 arg_type , new_ty = get_arg_type ~nolabel:false true ty in
- begin match arg_type with
- | NonNullString _ ->
- (* ?x:([`x of int ] [@bs.string]) does not make sense *)
- Location.raise_errorf
- ~loc
- "[@@bs.string] does not work with optional when it has arities in label %s" label
- | _ ->
- External_arg_spec.optional s, arg_type,
- ((label, Ast_core_type.lift_option_type new_ty , attr,loc) :: arg_types) end
- | Label s ->
- begin match get_arg_type ~nolabel:false false ty with
- | (Arg_cst ( i) as arg_type), new_ty ->
- External_arg_spec.label s (Some i), arg_type, arg_types
- | arg_type, new_ty ->
- External_arg_spec.label s None, arg_type, (label, new_ty,attr,loc) :: arg_types
- end
- | Empty ->
- begin match get_arg_type ~nolabel:true false ty with
- | (Arg_cst ( i) as arg_type), new_ty ->
- External_arg_spec.empty_lit i , arg_type, arg_types
- | arg_type, new_ty ->
- External_arg_spec.empty_label, arg_type, (label, new_ty,attr,loc) :: arg_types
- end
- in
- (if i = 0 && splice then
- match arg_type with
- | Array -> ()
- | _ -> Location.raise_errorf ~loc "[@@@@bs.splice] expect the last type to be an array");
- ({ External_arg_spec.arg_label ;
- arg_type
- } :: arg_type_specs,
- new_arg_types,
- if arg_type = Ignore then i
- else i + 1
- )
- ) arg_types_ty
- (match st with
- | {val_send_pipe = Some obj; _ } ->
- let arg_type, new_ty = get_arg_type ~nolabel:true false obj in
- begin match arg_type with
- | Arg_cst _ ->
- Location.raise_errorf ~loc:obj.ptyp_loc "[@bs.as] is not supported in bs.send type "
- | _ ->
- (* more error checking *)
- [External_arg_spec.empty_kind arg_type]
- ,
- ["", new_ty, [], obj.ptyp_loc]
- ,0
- end
- | {val_send_pipe = None ; _ } -> [],[], 0) in
- let ffi : External_ffi_types.attr = match st with
- | {set_index = true;
+val init : unit -> unit
- val_name = `Nm_na;
- external_module_name = None ;
- module_as_val = None;
- val_send = `Nm_na;
- val_send_pipe = None;
- splice = false;
- scopes ;
- get_index = false;
- new_name = `Nm_na;
- call_name = `Nm_na;
- set_name = `Nm_na ;
- get_name = `Nm_na ;
+end = struct
+#1 "ast_derive_projector.ml"
+open Ast_helper
- return_wrapper = _;
- mk_obj = _ ;
+let invalid_config (config : Parsetree.expression) =
+ Location.raise_errorf ~loc:config.pexp_loc "such configuration is not supported"
- }
- ->
- if String.length prim_name <> 0 then
- Location.raise_errorf ~loc "[@@bs.set_index] expect external names to be empty string";
- if arg_type_specs_length = 3 then
- Js_set_index {js_set_index_scopes = scopes}
- else
- Location.raise_errorf ~loc "Ill defined attribute [@@bs.set_index](arity of 3)"
- | {set_index = true; _}
- ->
- Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.set_index]")
+type tdcls = Parsetree.type_declaration list
- | {get_index = true;
+let derivingName = "accessors"
+let init () =
+
+ Ast_derive.register
+ derivingName
+ (fun (x : Parsetree.expression option) ->
+ (match x with
+ | Some config -> invalid_config config
+ | None -> ());
+ {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
+ ->
+ label_declarations
+ |> Ext_list.map (
+ 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
+ (Exp.fun_ "" None
+ (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
+ ->
+ constructor_declarations
+ |> Ext_list.map
+ (fun
+ ( {pcd_name = {loc ; txt = con_name} ; pcd_args ; pcd_loc }:
+ Parsetree.constructor_declaration)
+ -> (* TODO: add type annotations *)
+ let little_con_name = String.uncapitalize con_name in
+ let arity = List.length pcd_args 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)
+ core_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 = Longident.Lident (List.hd vars )}
+ else
+ Exp.tuple (Ext_list.map
+ (fun x -> Exp.ident {loc ; txt = Longident.Lident x})
+ vars
+ ) )) core_type
+ in
+ Ext_list.fold_right (fun var b ->
+ Exp.fun_ "" None (Pat.var {loc ; txt = var}) b
+ ) vars exp
- val_name = `Nm_na;
- external_module_name = None ;
- module_as_val = None;
- val_send = `Nm_na;
- val_send_pipe = None;
+ 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 handle_tdcl tdcls
- splice = false;
- scopes ;
- new_name = `Nm_na;
- call_name = `Nm_na;
- set_name = `Nm_na ;
- get_name = `Nm_na ;
- set_index = false;
- mk_obj;
- return_wrapper ;
- } ->
- if String.length prim_name <> 0 then
- Location.raise_errorf ~loc "[@@bs.get_index] expect external names to be empty string";
- if arg_type_specs_length = 2 then
- Js_get_index {js_get_index_scopes = scopes}
- else Location.raise_errorf ~loc
- "Ill defined attribute [@@bs.get_index] (arity expected 2 : while %d)" arg_type_specs_length
- | {get_index = true; _}
+ 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
+ ->
+ label_declarations
+ |> Ext_list.map
+ (fun
+ ({pld_name ;
+ pld_type
+ } :
+ Parsetree.label_declaration) ->
+ Ast_comb.single_non_rec_val pld_name (Typ.arrow "" core_type pld_type )
+ )
+ | Ptype_variant constructor_declarations
+ ->
+ constructor_declarations
+ |>
+ Ext_list.map
+ (fun ({pcd_name = {loc ; txt = con_name} ; pcd_args ; pcd_loc }:
+ Parsetree.constructor_declaration)
+ ->
+ Ast_comb.single_non_rec_val {loc ; txt = (String.uncapitalize con_name)}
+ (Ext_list.fold_right
+ (fun x acc -> Typ.arrow "" x acc)
+ pcd_args
+ core_type))
+ | Ptype_open | Ptype_abstract ->
+ Ast_derive_util.notApplicable tdcl.ptype_loc derivingName ;
+ []
+ in
+ Ext_list.flat_map handle_tdcl tdcls
+ end;
+ expression_gen = None
+ }
+ )
- ->
- Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.get_index]")
+end
+module Ast_exp_apply : sig
+#1 "ast_exp_apply.mli"
+(* Copyright (C) 2018 Authors of BuckleScript
+ *
+ * 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 handle_exp_apply :
+ Parsetree.expression ->
+ Bs_ast_mapper.mapper ->
+ Parsetree.expression ->
+ (Asttypes.label * Parsetree.expression) list ->
+ Parsetree.expression
- | {module_as_val = Some external_module_name ;
+end = struct
+#1 "ast_exp_apply.ml"
+(* Copyright (C) 2018 Authors of BuckleScript
+ *
+ * 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. *)
- get_index = false;
- val_name ;
- new_name ;
+open Ast_helper
- external_module_name = None ;
- val_send = `Nm_na;
- val_send_pipe = None;
- scopes = []; (* module as var does not need scopes *)
- splice;
- call_name = `Nm_na;
- set_name = `Nm_na ;
- get_name = `Nm_na ;
- set_index = false;
- return_wrapper = _;
- mk_obj = _ ;
- } ->
- begin match arg_types_ty, new_name, val_name with
- | [], `Nm_na, _ -> Js_module_as_var external_module_name
- | _, `Nm_na, _ -> Js_module_as_fn {splice; external_module_name }
- | _, #bundle_source, #bundle_source ->
- Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.module].")
+let handle_exp_apply
+ (e : Parsetree.expression)
+ (self : Bs_ast_mapper.mapper)
+ (fn : Parsetree.expression)
+ (args : (Asttypes.label * Parsetree.expression) list)
+ =
+ let loc = e.pexp_loc in
+ begin match fn with
+ | {pexp_desc =
+ Pexp_apply (
+ {pexp_desc =
+ Pexp_ident {txt = Lident "##" ; loc} ; _},
+ [("", obj) ;
+ ("", {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _} )
+ ]);
+ _} -> (* f##paint 1 2 *)
+ {e with pexp_desc = Ast_util.method_apply loc self obj name args }
+ | {pexp_desc =
+ Pexp_apply (
+ {pexp_desc =
+ Pexp_ident {txt = Lident "#@" ; loc} ; _},
+ [("", obj) ;
+ ("", {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _} )
+ ]);
+ _} -> (* f##paint 1 2 *)
+ {e with pexp_desc = Ast_util.property_apply loc self obj name args }
+
+ | {pexp_desc =
+ Pexp_ident {txt = Lident "##" ; loc} ; _}
+ ->
+ begin match args with
+ | [("", obj) ;
+ ("", {pexp_desc = Pexp_apply(
+ {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _},
+ args
+ ); pexp_attributes = attrs }
+ (* we should warn when we discard attributes *)
+ )
+ ] -> (* f##(paint 1 2 ) *)
+ (* gpr#1063 foo##(bar##baz) we should rewrite (bar##baz)
+ first before pattern match.
+ currently the pattern match is written in a top down style.
+ Another corner case: f##(g a b [@bs])
+ *)
+ Bs_ast_invariant.warn_unused_attributes attrs ;
+ {e with pexp_desc = Ast_util.method_apply loc self obj name args}
+ | [("", obj) ;
+ ("",
+ {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _}
+ ) (* f##paint *)
+ ] ->
+ { e with pexp_desc =
+ Ast_util.js_property loc (self.expr self obj) name
+ }
- | _, (`Nm_val _ | `Nm_external _) , `Nm_na
- -> Js_module_as_class external_module_name
- | _, `Nm_payload _ , `Nm_na
- ->
- Location.raise_errorf ~loc
- "Incorrect FFI attribute found: (bs.new should not carry a payload here)"
- end
- | {module_as_val = Some x; _}
- ->
- Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.module].")
+ | _ ->
+ Location.raise_errorf ~loc
+ "Js object ## expect syntax like obj##(paint (a,b)) "
+ end
+ (* we can not use [:=] for precedece cases
+ like {[i @@ x##length := 3 ]}
+ is parsed as {[ (i @@ x##length) := 3]}
+ since we allow user to create Js objects in OCaml, it can be of
+ ref type
+ {[
+ let u = object (self)
+ val x = ref 3
+ method setX x = self##x := 32
+ method getX () = !self##x
+ end
+ ]}
+ *)
+ | {pexp_desc =
+ Pexp_ident {txt = Lident ("#=" )}
+ } ->
+ begin match args with
+ | ["",
+ {pexp_desc =
+ Pexp_apply ({pexp_desc = Pexp_ident {txt = Lident "##"}},
+ ["", obj;
+ "", {pexp_desc = Pexp_ident {txt = Lident name}}
+ ]
+ )};
+ "", arg
+ ] ->
+ Exp.constraint_ ~loc
+ { e with
+ pexp_desc =
+ Ast_util.method_apply loc self obj
+ (name ^ Literals.setter_suffix) ["", arg ] }
+ (Ast_literal.type_unit ~loc ())
+ | _ -> Bs_ast_mapper.default_mapper.expr self e
+ end
+ | _ ->
+ begin match
+ Ext_list.exclude_with_val
+ Ast_attributes.is_bs e.pexp_attributes with
+ | false, _ -> Bs_ast_mapper.default_mapper.expr self e
+ | true, pexp_attributes ->
+ {e with pexp_desc = Ast_util.uncurry_fn_apply loc self fn args ;
+ pexp_attributes }
+ end
+ end
- | {call_name = (`Nm_val name | `Nm_external name | `Nm_payload name) ;
- splice;
- scopes ;
- external_module_name;
+end
+module Ast_exp_extension : sig
+#1 "ast_exp_extension.mli"
+(* Copyright (C) 2018 Authors of BuckleScript
+ *
+ * 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_name = `Nm_na ;
- module_as_val = None;
- val_send = `Nm_na ;
- val_send_pipe = None;
- set_index = false;
- get_index = false;
- new_name = `Nm_na;
- set_name = `Nm_na ;
- get_name = `Nm_na ;
- mk_obj = _ ;
- return_wrapper = _ ;
- } ->
- Js_call {splice; name; external_module_name; scopes }
- | {call_name = #bundle_source ; _ }
- ->
- Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.val]")
+val handle_extension :
+ bool ref ->
+ Parsetree.expression ->
+ Bs_ast_mapper.mapper ->
+ Parsetree.extension ->
+ Parsetree.expression
+end = struct
+#1 "ast_exp_extension.ml"
+(* Copyright (C) 2018 Authors of BuckleScript
+ *
+ * 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. *)
+open Ast_helper
- | {val_name = (`Nm_val name | `Nm_external name | `Nm_payload name);
- external_module_name;
+let handle_extension record_as_js_object e (self : Bs_ast_mapper.mapper)
+ (({txt ; loc} as lid , payload) : Parsetree.extension) =
+ begin match txt with
+ | "bs.raw" | "raw" ->
+ Ast_util.handle_raw loc payload
+ | "bs.re" | "re" ->
+ Exp.constraint_ ~loc
+ (Ast_util.handle_raw ~check_js_regex:true loc payload)
+ (Ast_comb.to_js_re_type loc)
+ | "bs.external" | "external" ->
+ begin match Ast_payload.as_ident payload with
+ | Some {txt = Lident x}
+ -> Ast_util.handle_external loc x
+ (* do we need support [%external gg.xx ]
+
+ {[ Js.Undefined.to_opt (if Js.typeof x == "undefined" then x else Js.Undefined.empty ) ]}
+ *)
- call_name = `Nm_na ;
- module_as_val = None;
- val_send = `Nm_na ;
- val_send_pipe = None;
- set_index = false;
- get_index = false;
- new_name = `Nm_na;
- set_name = `Nm_na ;
- get_name = `Nm_na;
- mk_obj = _;
- return_wrapper = _;
- splice = false ;
- scopes ;
- }
- ->
- Js_global { name; external_module_name; scopes}
- | {val_name = #bundle_source ; _ }
- ->
- Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.val]")
+ | None | Some _ ->
+ Location.raise_errorf ~loc
+ "external expects a single identifier"
+ end
+ | "bs.time"| "time" ->
+ (
+ match payload with
+ | PStr [{pstr_desc = Pstr_eval (e,_)}] ->
+ let locString =
+ if loc.loc_ghost then
+ "GHOST LOC"
+ else
+ let loc_start = loc.loc_start in
+ let (file, lnum, __) = Location.get_pos_info loc_start in
+ Printf.sprintf "%s %d"
+ file lnum in
+ let e = self.expr self e in
+ Exp.sequence ~loc
+ (Exp.apply ~loc
+ (Exp.ident ~loc {loc;
+ txt =
+ Ldot (Ldot (Lident "Js", "Console"), "timeStart")
+ })
+ ["", Exp.constant ~loc (Const_string (locString,None))]
+ )
+ ( Exp.let_ ~loc Nonrecursive
+ [Vb.mk ~loc (Pat.var ~loc {loc; txt = "timed"}) e ;
+ ]
+ (Exp.sequence ~loc
+ (Exp.apply ~loc
+ (Exp.ident ~loc {loc;
+ txt =
+ Ldot (Ldot (Lident "Js", "Console"), "timeEnd")
+ })
+ ["", Exp.constant ~loc (Const_string (locString,None))]
+ )
+ (Exp.ident ~loc {loc; txt = Lident "timed"})
+ )
+ )
+ | _ ->
+ Location.raise_errorf
+ ~loc "expect a boolean expression in the payload"
+ )
+ | "bs.assert" | "assert" ->
+ (
+ match payload with
+ | PStr [ {pstr_desc = Pstr_eval( e,_)}] ->
- | {splice ;
- scopes ;
- external_module_name = (Some _ as external_module_name);
+ let locString =
+ if loc.loc_ghost then
+ "ASSERT FAILURE"
+ else
+ let loc_start = loc.loc_start in
+ let (file, lnum, cnum) = Location.get_pos_info loc_start in
+ let enum =
+ loc.Location.loc_end.Lexing.pos_cnum -
+ loc_start.Lexing.pos_cnum + cnum in
+ Printf.sprintf "File %S, line %d, characters %d-%d"
+ file lnum cnum enum in
+ let raiseWithString locString =
+ (Exp.apply ~loc
+ (Exp.ident ~loc {loc; txt =
+ Ldot(Ldot (Lident "Js","Exn"),"raiseError")})
+ ["",
+
+ Exp.constant (Const_string (locString,None))
+ ])
+ in
+ (match e.pexp_desc with
+ | Pexp_construct({txt = Lident "false"},None) ->
+ (* The backend will convert [assert false] into a nop later *)
+ if !Clflags.no_assert_false then
+ Exp.assert_ ~loc
+ (Exp.construct ~loc {txt = Lident "false";loc} None)
+ else
+ (raiseWithString locString)
+ | Pexp_constant (Const_string (r, _)) ->
+ if !Clflags.noassert then
+ Exp.assert_ ~loc (Exp.construct ~loc {txt = Lident "true"; loc} None)
+ (* Need special handling to make it type check*)
+ else
+ raiseWithString r
+ | _ ->
+ let e = self.expr self e in
+ if !Clflags.noassert then
+ (* pass down so that it still type check, but the backend will
+ make it a nop
+ *)
+ Exp.assert_ ~loc e
+ else
+ Exp.ifthenelse ~loc
+ (Exp.apply ~loc
+ (Exp.ident {loc ; txt = Ldot(Lident "Pervasives","not")})
+ ["", e]
+ )
+ (raiseWithString locString)
+ None
+ )
+ | _ ->
+ Location.raise_errorf
+ ~loc "expect a boolean expression in the payload"
+ )
+ | "bs.node" | "node" ->
+ let strip s =
+ match s with
+ | "_module" -> "module"
+ | x -> x in
+ begin match Ast_payload.as_ident payload with
+ | Some {txt = Lident
+ ( "__filename"
+ | "__dirname"
+ | "_module"
+ | "require" as name); loc}
+ ->
+ let exp =
+ Ast_util.handle_external loc (strip name) in
+ let typ =
+ Ast_core_type.lift_option_type
+ @@
+ if name = "_module" then
+ Typ.constr ~loc
+ { txt = Ldot (Lident "Node", "node_module") ;
+ loc} []
+ else if name = "require" then
+ (Typ.constr ~loc
+ { txt = Ldot (Lident "Node", "node_require") ;
+ loc} [] )
+ else
+ Ast_literal.type_string ~loc () in
+ Exp.constraint_ ~loc exp typ
+ | Some _ | None ->
+ begin match payload with
+ | PTyp _ ->
+ Location.raise_errorf
+ ~loc "Illegal payload, expect an expression payload instead of type payload"
+ | PPat _ ->
+ Location.raise_errorf
+ ~loc "Illegal payload, expect an expression payload instead of pattern payload"
+ | _ ->
+ Location.raise_errorf
+ ~loc "Illegal payload"
+ end
- val_name = `Nm_na ;
- call_name = `Nm_na ;
- module_as_val = None;
- val_send = `Nm_na ;
- val_send_pipe = None;
- set_index = false;
- get_index = false;
- new_name = `Nm_na;
- set_name = `Nm_na ;
- get_name = `Nm_na ;
- mk_obj = _ ;
- return_wrapper= _ ;
- }
- ->
- let name = string_of_bundle_source prim_name_or_pval_prim in
- if arg_type_specs_length = 0 then
- Js_global { name; external_module_name; scopes}
- else Js_call {splice; name; external_module_name; scopes}
- | {val_send = (`Nm_val name | `Nm_external name | `Nm_payload name);
- splice;
- scopes;
- val_send_pipe = None;
- val_name = `Nm_na ;
- call_name = `Nm_na ;
- module_as_val = None;
- set_index = false;
- get_index = false;
- new_name = `Nm_na;
- set_name = `Nm_na ;
- get_name = `Nm_na ;
- external_module_name = None ;
- mk_obj = _ ;
- return_wrapper = _ ;
- } ->
+ end
+ | "bs.debugger"|"debugger" ->
+ {e with pexp_desc = Ast_util.handle_debugger loc payload}
+ | "bs.obj" | "obj" ->
+ begin match payload with
+ | PStr [{pstr_desc = Pstr_eval (e,_)}]
+ ->
+ Ext_ref.non_exn_protect record_as_js_object true
+ (fun () -> self.expr self e )
+ | _ -> Location.raise_errorf ~loc "Expect an expression here"
+ end
+ | _ ->
+ match payload with
+ | PTyp typ when Ext_string.starts_with txt Literals.bs_deriving_dot ->
+ self.expr self (Ast_derive.gen_expression lid typ)
+ | _ ->
+ e (* For an unknown extension, we don't really need to process further*)
+ (* Exp.extension ~loc ~attrs:e.pexp_attributes (
+ self.extension self extension) *)
+ (* Bs_ast_mapper.default_mapper.expr self e *)
+ end
- (* PR #2162 - since when we assemble arguments the first argument in
- [@@bs.send] is ignored
- *)
- begin match arg_type_specs with
- | [] ->
- Location.raise_errorf
- ~loc "Ill defined attribute [@@bs.send] (at least one argument)"
- | {arg_type = Arg_cst _ ; arg_label = _} :: _
- ->
- Location.raise_errorf
- ~loc "Ill defined attribute [@@bs.send] (first argument can not be const)"
- | _ :: _ ->
- Js_send {splice ; name; js_send_scopes = scopes ; pipe = false}
- end
+end
+module Ast_tuple_pattern_flatten : sig
+#1 "ast_tuple_pattern_flatten.mli"
+(* Copyright (C) 2018 Authors of BuckleScript
+ *
+ * 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_send = #bundle_source; _ }
- -> Location.raise_errorf ~loc "You used an FFI attribute that can't be used with [@@bs.send]"
- | {val_send_pipe = Some typ;
- (* splice = (false as splice); *)
- val_send = `Nm_na;
- val_name = `Nm_na ;
- call_name = `Nm_na ;
- module_as_val = None;
- set_index = false;
- get_index = false;
- new_name = `Nm_na;
- set_name = `Nm_na ;
- get_name = `Nm_na ;
- external_module_name = None ;
- mk_obj = _;
- return_wrapper = _;
- scopes;
- splice ;
- } ->
- (** can be one argument *)
- Js_send {splice ;
- name = string_of_bundle_source prim_name_or_pval_prim;
- js_send_scopes = scopes;
- pipe = true}
- | {val_send_pipe = Some _ ; _}
- -> Location.raise_errorf ~loc "conflict attributes found with [@@bs.send.pipe]"
+val handle_value_bindings :
+ Bs_ast_mapper.mapper ->
+ Parsetree.value_binding list ->
+ Parsetree.value_binding list
+end = struct
+#1 "ast_tuple_pattern_flatten.ml"
+(* Copyright (C) 2018 Authors of BuckleScript
+ *
+ * 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. *)
- | {new_name = (`Nm_val name | `Nm_external name | `Nm_payload name);
- external_module_name;
+ type loc = Location.t
- val_name = `Nm_na ;
- call_name = `Nm_na ;
- module_as_val = None;
- set_index = false;
- get_index = false;
- val_send = `Nm_na ;
- val_send_pipe = None;
- set_name = `Nm_na ;
- get_name = `Nm_na ;
- splice ;
- scopes;
- mk_obj = _ ;
- return_wrapper = _ ;
+ type acc =
+ (Asttypes.override_flag * Longident.t Asttypes.loc * loc *
+ Parsetree.attributes) list
- }
- -> Js_new {name; external_module_name; splice; scopes}
- | {new_name = #bundle_source ; _ }
- ->
- Bs_syntaxerr.err loc (Conflict_ffi_attribute "Attribute found that conflicts with [@@bs.new]")
+let rec is_simple_pattern (p : Parsetree.pattern) =
+ match p.ppat_desc with
+ | Ppat_any -> true
+ | Ppat_var _ -> true
+ | Ppat_constraint(p,_) -> is_simple_pattern p
+ | _ -> false
+
+(**
+ destruct such pattern
+ {[ A.B.let open C in (a,b)]}
+*)
+let rec destruct_open
+ (e : Parsetree.expression) (acc : acc)
+ : (acc * Parsetree.expression list) option =
+ match e.pexp_desc with
+ | Pexp_open (flag, lid, cont)
+ ->
+ destruct_open
+ cont
+ ((flag, lid, e.pexp_loc, e.pexp_attributes) :: acc)
+ | Pexp_tuple es -> Some (acc, es)
+ | _ -> None
- | {set_name = (`Nm_val name | `Nm_external name | `Nm_payload name);
+(*
+ [let (a,b) = M.N.(c,d) ]
+ =>
+ [ let a = M.N.c
+ and b = M.N.d ]
+*)
+let flattern_tuple_pattern_vb
+ (self : Bs_ast_mapper.mapper)
+ ({pvb_loc } as vb : Parsetree.value_binding)
+ acc : Parsetree.value_binding list =
+ let pvb_pat = self.pat self vb.pvb_pat in
+ let pvb_expr = self.expr self vb.pvb_expr in
+ let pvb_attributes = self.attributes self vb.pvb_attributes in
+ match destruct_open pvb_expr [] , pvb_pat.ppat_desc with
+ | Some (wholes, es), Ppat_tuple xs
+ when
+ List.for_all is_simple_pattern xs &&
+ Ext_list.same_length es xs
+ ->
+ (Ext_list.fold_right2 (fun pat exp acc->
+ {Parsetree.
+ pvb_pat =
+ pat;
+ pvb_expr =
+ ( match wholes with
+ | [] -> exp
+ | _ ->
+ List.fold_left (fun x (flag,lid,loc,attrs) ->
+ {Parsetree.
+ pexp_desc = Pexp_open(flag,lid,x);
+ pexp_attributes = attrs;
+ pexp_loc = loc
+ }
+ ) exp wholes) ;
+ pvb_attributes;
+ pvb_loc ;
+ } :: acc
+ ) xs es) acc
+ | _ ->
+ {pvb_pat ;
+ pvb_expr ;
+ pvb_loc ;
+ pvb_attributes} :: acc
- val_name = `Nm_na ;
- call_name = `Nm_na ;
- module_as_val = None;
- set_index = false;
- get_index = false;
- val_send = `Nm_na ;
- val_send_pipe = None;
- new_name = `Nm_na ;
- get_name = `Nm_na ;
- external_module_name = None;
- splice = false;
- mk_obj = _ ;
- return_wrapper = _;
- scopes ;
- }
- ->
- if arg_type_specs_length = 2 then
- Js_set { js_set_scopes = scopes ; js_set_name = name}
- else Location.raise_errorf ~loc "Ill defined attribute [@@bs.set] (two args required)"
- | {set_name = #bundle_source; _}
- -> Location.raise_errorf ~loc "conflict attributes found with [@@bs.set]"
- | {get_name = (`Nm_val name | `Nm_external name | `Nm_payload name);
+let handle_value_bindings =
+ fun self (vbs : Parsetree.value_binding list) ->
+ (* Bs_ast_mapper.default_mapper.value_bindings self vbs *)
+ List.fold_right (fun vb acc ->
+ flattern_tuple_pattern_vb self vb acc
+ ) vbs []
+end
+module Ast_utf8_string : sig
+#1 "ast_utf8_string.mli"
+(* 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_name = `Nm_na ;
- call_name = `Nm_na ;
- module_as_val = None;
- set_index = false;
- get_index = false;
- val_send = `Nm_na ;
- val_send_pipe = None;
- new_name = `Nm_na ;
- set_name = `Nm_na ;
- external_module_name = None;
- splice = false ;
- mk_obj = _;
- return_wrapper = _;
- scopes
- }
- ->
- if arg_type_specs_length = 1 then
- Js_get { js_get_name = name; js_get_scopes = scopes }
- else
- Location.raise_errorf ~loc "Ill defined attribute [@@bs.get] (only one argument)"
- | {get_name = #bundle_source; _}
- -> Location.raise_errorf ~loc "Attribute found that conflicts with [@@bs.get]"
- | {get_name = `Nm_na;
- val_name = `Nm_na ;
- call_name = `Nm_na ;
- module_as_val = None;
- set_index = false;
- get_index = false;
- val_send = `Nm_na ;
- val_send_pipe = None;
- new_name = `Nm_na ;
- set_name = `Nm_na ;
- external_module_name = None;
- splice = _ ;
- scopes = _;
- mk_obj = _;
- return_wrapper = _;
+type error
- }
- -> Location.raise_errorf ~loc "Could not infer which FFI category it belongs to, maybe you forgot [%@%@bs.val]? " in
- begin
- External_ffi_types.check_ffi ~loc ffi;
- (* result type can not be labeled *)
- (* currently we don't process attributes of
- return type, in the future we may *)
- let new_result_type = result_type in
- (* get_arg_type ~nolabel:true false result_type in *)
- let return_wrapper : External_ffi_types.return_wrapper =
- check_return_wrapper loc st.return_wrapper new_result_type
- in
- (
- Ext_list.fold_right (fun (label,ty,attrs,loc) acc ->
- Ast_helper.Typ.arrow ~loc ~attrs label ty acc
- ) new_arg_types_ty new_result_type
- ) ,
- prim_name,
- (Ffi_bs (arg_type_specs,return_wrapper , ffi)), left_attrs
- end
+type exn += Error of int (* offset *) * error
-let handle_attributes_as_string
- pval_loc
- pval_prim
- (typ : Ast_core_type.t) attrs v =
- let pval_type, prim_name, ffi, processed_attrs =
- handle_attributes pval_loc pval_prim typ attrs v in
- pval_type, [prim_name; External_ffi_types.to_string ffi], processed_attrs
+val pp_error : Format.formatter -> error -> unit
+
+(* module Interp : sig *)
+(* val check_and_transform : int -> string -> int -> cxt -> unit *)
+(* val transform_test : string -> segments *)
+(* end *)
+val transform_test : string -> string
-let pval_prim_of_labels labels =
- let encoding =
- let arg_kinds =
- Ext_list.fold_right
- (fun {Asttypes.loc ; txt } arg_kinds
- ->
- let arg_label = External_arg_spec.label (Lam_methname.translate ~loc txt) None in
- {External_arg_spec.arg_type = Nothing ;
- arg_label } :: arg_kinds
- )
- labels [] in
- External_ffi_types.to_string
- (Ffi_obj_create arg_kinds) in
- [""; encoding]
+val transform : Location.t -> string -> string
-end
-module Ast_util : sig
-#1 "ast_util.mli"
+end = struct
+#1 "ast_utf8_string.ml"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -109958,116 +110989,183 @@ module Ast_util : sig
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
-type args = (string * Parsetree.expression) list
-type loc = Location.t
-type label_exprs = (Longident.t Asttypes.loc * Parsetree.expression) list
-type 'a cxt = loc -> Bs_ast_mapper.mapper -> 'a
-
-(** In general three kinds of ast generation.
- - convert a curried to type to uncurried
- - convert a curried fun to uncurried fun
- - convert a uncuried application to normal
-*)
-type uncurry_expression_gen =
- (Parsetree.pattern ->
- Parsetree.expression ->
- Parsetree.expression_desc) cxt
-type uncurry_type_gen =
- (string -> (* label for error checking *)
- Parsetree.core_type ->
- Parsetree.core_type ->
- Parsetree.core_type) cxt
-(** TODO: the interface is not reusable, it depends on too much context *)
-(** syntax: {[f arg0 arg1 [@bs]]}*)
-val uncurry_fn_apply :
- (Parsetree.expression ->
- args ->
- Parsetree.expression_desc ) cxt
+type error =
+ | Invalid_code_point
+ | Unterminated_backslash
+ | Invalid_escape_code of char
+ | Invalid_hex_escape
+ | Invalid_unicode_escape
-(** syntax : {[f## arg0 arg1 ]}*)
-val method_apply :
- (Parsetree.expression ->
- string ->
- args ->
- Parsetree.expression_desc) cxt
+let pp_error fmt err =
+ Format.pp_print_string fmt @@ match err with
+ | Invalid_code_point -> "Invalid code point"
+ | Unterminated_backslash -> "\\ ended unexpectedly"
+ | Invalid_escape_code c -> "Invalid escape code: " ^ String.make 1 c
+ | Invalid_hex_escape ->
+ "Invalid \\x escape"
+ | Invalid_unicode_escape -> "Invalid \\u escape"
-(** syntax {[f#@ arg0 arg1 ]}*)
-val property_apply :
- (Parsetree.expression ->
- string ->
- args ->
- Parsetree.expression_desc) cxt
-(**
- [function] can only take one argument, that is the reason we did not adopt it
- syntax:
- {[ fun [@bs] pat pat1-> body ]}
- [to_uncurry_fn (fun pat -> (fun pat1 -> ... body))]
+type exn += Error of int (* offset *) * error
-*)
-val to_uncurry_fn : uncurry_expression_gen
-(** syntax:
- {[fun [@bs.this] obj pat pat1 -> body]}
-*)
-val to_method_callback : uncurry_expression_gen
+let error ~loc error =
+ raise (Error (loc, error))
-(** syntax :
- {[ int -> int -> int [@bs]]}
+(** Note the [loc] really should be the utf8-offset, it has nothing to do with our
+ escaping mechanism
*)
-val to_uncurry_type : uncurry_type_gen
-
+(* we can not just print new line in ES5
+ seems we don't need
+ escape "\b" "\f"
+ we need escape "\n" "\r" since
+ ocaml multiple-line allows [\n]
+ visual input while es5 string
+ does not*)
-(** syntax
- {[ method : int -> itn -> int ]}
-*)
-val to_method_type : uncurry_type_gen
+let rec check_and_transform (loc : int ) buf s byte_offset s_len =
+ if byte_offset = s_len then ()
+ else
+ let current_char = s.[byte_offset] in
+ match Ext_utf8.classify current_char with
+ | Single 92 (* '\\' *) ->
+ escape_code (loc + 1) buf s (byte_offset+1) s_len
+ | Single 34 ->
+ Buffer.add_string buf "\\\"";
+ check_and_transform (loc + 1) buf s (byte_offset + 1) s_len
+ | Single 39 ->
+ Buffer.add_string buf "\\'";
+ check_and_transform (loc + 1) buf s (byte_offset + 1) s_len
+ | Single 10 ->
+ Buffer.add_string buf "\\n";
+ check_and_transform (loc + 1) buf s (byte_offset + 1) s_len
+ | Single 13 ->
+ Buffer.add_string buf "\\r";
+ check_and_transform (loc + 1) buf s (byte_offset + 1) s_len
+ | Single _ ->
+ Buffer.add_char buf current_char;
+ check_and_transform (loc + 1) buf s (byte_offset + 1) s_len
-(** syntax:
- {[ 'obj -> int -> int [@bs.this] ]}
-*)
-val to_method_callback_type : uncurry_type_gen
+ | Invalid
+ | Cont _ -> error ~loc Invalid_code_point
+ | Leading (n,_) ->
+ let i' = Ext_utf8.next s ~remaining:n byte_offset in
+ if i' < 0 then
+ error ~loc Invalid_code_point
+ else
+ begin
+ for k = byte_offset to i' do
+ Buffer.add_char buf s.[k];
+ done;
+ check_and_transform (loc + 1 ) buf s (i' + 1) s_len
+ end
+(* we share the same escape sequence with js *)
+and escape_code loc buf s offset s_len =
+ if offset >= s_len then
+ error ~loc Unterminated_backslash
+ else
+ Buffer.add_char buf '\\';
+ let cur_char = s.[offset] in
+ match cur_char with
+ | '\\'
+ | 'b'
+ | 't'
+ | 'n'
+ | 'v'
+ | 'f'
+ | 'r'
+ | '0'
+ | '$'
+ ->
+ begin
+ Buffer.add_char buf cur_char ;
+ check_and_transform (loc + 1) buf s (offset + 1) s_len
+ end
+ | 'u' ->
+ begin
+ Buffer.add_char buf cur_char;
+ unicode (loc + 1) buf s (offset + 1) s_len
+ end
+ | 'x' -> begin
+ Buffer.add_char buf cur_char ;
+ two_hex (loc + 1) buf s (offset + 1) s_len
+ end
+ | _ -> error ~loc (Invalid_escape_code cur_char)
+and two_hex loc buf s offset s_len =
+ if offset + 1 >= s_len then
+ error ~loc Invalid_hex_escape;
+ (*Location.raise_errorf ~loc "\\x need at least two chars";*)
+ let a, b = s.[offset], s.[offset + 1] in
+ if Ext_char.valid_hex a && Ext_char.valid_hex b then
+ begin
+ Buffer.add_char buf a ;
+ Buffer.add_char buf b ;
+ check_and_transform (loc + 2) buf s (offset + 2) s_len
+ end
+ else
+ error ~loc Invalid_hex_escape
+(*Location.raise_errorf ~loc "%c%c is not a valid hex code" a b*)
+
+and unicode loc buf s offset s_len =
+ if offset + 3 >= s_len then
+ error ~loc Invalid_unicode_escape
+ (*Location.raise_errorf ~loc "\\u need at least four chars"*)
+ ;
+ let a0,a1,a2,a3 = s.[offset], s.[offset+1], s.[offset+2], s.[offset+3] in
+ if
+ Ext_char.valid_hex a0 &&
+ Ext_char.valid_hex a1 &&
+ Ext_char.valid_hex a2 &&
+ Ext_char.valid_hex a3 then
+ begin
+ Buffer.add_char buf a0;
+ Buffer.add_char buf a1;
+ Buffer.add_char buf a2;
+ Buffer.add_char buf a3;
+ check_and_transform (loc + 4) buf s (offset + 4) s_len
+ end
+ else
+ error ~loc Invalid_unicode_escape
+(*Location.raise_errorf ~loc "%c%c%c%c is not a valid unicode point"
+ a0 a1 a2 a3 *)
+(* http://www.2ality.com/2015/01/es6-strings.html
+ console.log('\uD83D\uDE80'); (* ES6*)
+ console.log('\u{1F680}');
+*)
-val record_as_js_object :
- (label_exprs ->
- Parsetree.expression_desc) cxt
-val js_property :
- loc ->
- Parsetree.expression -> string -> Parsetree.expression_desc
-val handle_debugger :
- loc -> Ast_payload.t -> Parsetree.expression_desc
-val handle_raw :
- ?check_js_regex: bool -> loc -> Ast_payload.t -> Parsetree.expression
-val handle_external :
- loc -> string -> Parsetree.expression
-
-val handle_raw_structure :
- loc -> Ast_payload.t -> Parsetree.structure_item
+let transform_test s =
+ let s_len = String.length s in
+ let buf = Buffer.create (s_len * 2) in
+ check_and_transform 0 buf s 0 s_len;
+ Buffer.contents buf
-val ocaml_obj_as_js_object :
- (Parsetree.pattern ->
- Parsetree.class_field list ->
- Parsetree.expression_desc) cxt
+let transform loc s =
+ let s_len = String.length s in
+ let buf = Buffer.create (s_len * 2) in
+ try
+ check_and_transform 0 buf s 0 s_len;
+ Buffer.contents buf
+ with
+ Error (offset, error)
+ -> Location.raise_errorf ~loc "Offset: %d, %a" offset pp_error error
- val convertBsErrorFunction :
-
- (Ast_helper.attrs -> Parsetree.case list -> Parsetree.expression) cxt
-end = struct
-#1 "ast_util.ml"
+end
+module Ast_utf8_string_interp : sig
+#1 "ast_utf8_string_interp.mli"
(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
*
* This program is free software: you can redistribute it and/or modify
@@ -110089,790 +111187,503 @@ end = struct
* 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. *)
-
-open Ast_helper
-type 'a cxt = Ast_helper.loc -> Bs_ast_mapper.mapper -> 'a
-type loc = Location.t
-type args = (string * Parsetree.expression) list
-type label_exprs = (Longident.t Asttypes.loc * Parsetree.expression) list
-type uncurry_expression_gen =
- (Parsetree.pattern ->
- Parsetree.expression ->
- Parsetree.expression_desc) cxt
-type uncurry_type_gen =
- (string ->
- Parsetree.core_type ->
- Parsetree.core_type ->
- Parsetree.core_type) cxt
-
-let uncurry_type_id =
- Ast_literal.Lid.js_fn
-
-let method_id =
- Ast_literal.Lid.js_meth
-
-let method_call_back_id =
- Ast_literal.Lid.js_meth_callback
-
-let arity_lit = "Arity_"
-
-let mk_args loc n tys =
- Typ.variant ~loc
- [ Rtag (arity_lit ^ string_of_int n, [], (n = 0), tys)] Closed None
-
-let generic_lift txt loc args result =
- let xs =
- match args with
- | [ ] -> [mk_args loc 0 [] ; result ]
- | [ x ] -> [ mk_args loc 1 [x] ; result ]
- | _ ->
- [mk_args loc (List.length args ) [Typ.tuple ~loc args] ; result ]
- in
- Typ.constr ~loc {txt ; loc} xs
-
-let lift_curry_type loc =
- generic_lift uncurry_type_id loc
-
-let lift_method_type loc =
- generic_lift method_id loc
-
-let lift_js_method_callback loc
- =
- generic_lift method_call_back_id loc
-(** Note that currently there is no way to consume [Js.meth_callback]
- so it is fine to encode it with a freedom,
- but we need make it better for error message.
- - all are encoded as
- {[
- type fn = (`Args_n of _ , 'result ) Js.fn
- type method = (`Args_n of _, 'result) Js.method
- type method_callback = (`Args_n of _, 'result) Js.method_callback
- ]}
- For [method_callback], the arity is never zero, so both [method]
- and [fn] requires (unit -> 'a) to encode arity zero
-*)
-
-
-
-let arrow = Typ.arrow
-
-
-let js_property loc obj name =
- Parsetree.Pexp_send
- ((Exp.apply ~loc
- (Exp.ident ~loc
- {loc;
- txt = Ldot (Ast_literal.Lid.js_unsafe, Literals.unsafe_downgrade)})
- ["",obj]), name)
-
-(* TODO:
- have a final checking for property arities
- [#=],
-*)
-
-
-let generic_apply kind loc
- (self : Bs_ast_mapper.mapper)
- (obj : Parsetree.expression)
- (args : args ) cb =
- let obj = self.expr self obj in
- let args =
- Ext_list.map (fun (label,e) ->
- if label <> "" then
- Bs_syntaxerr.err loc Label_in_uncurried_bs_attribute;
- self.expr self e
- ) args in
- let len = List.length args in
- let arity, fn, args =
- match args with
- | [ {pexp_desc =
- Pexp_construct ({txt = Lident "()"}, None)}]
- ->
- 0, cb loc obj, []
- | _ ->
- len, cb loc obj, args in
- if arity < 10 then
- let txt =
- match kind with
- | `Fn | `PropertyFn ->
- Longident.Ldot (Ast_literal.Lid.js_unsafe,
- Literals.fn_run ^ string_of_int arity)
- | `Method ->
- Longident.Ldot(Ast_literal.Lid.js_unsafe,
- Literals.method_run ^ string_of_int arity
- ) in
- Parsetree.Pexp_apply (Exp.ident {txt ; loc}, ("",fn) :: Ext_list.map (fun x -> "",x) args)
- else
- let fn_type, args_type, result_type = Ast_comb.tuple_type_pair ~loc `Run arity in
- let string_arity = string_of_int arity in
- let pval_prim, pval_type =
- match kind with
- | `Fn | `PropertyFn ->
- ["#fn_run"; string_arity],
- arrow ~loc "" (lift_curry_type loc args_type result_type ) fn_type
- | `Method ->
- ["#method_run" ; string_arity],
- arrow ~loc "" (lift_method_type loc args_type result_type) fn_type
- in
- Ast_external_mk.local_external loc ~pval_prim ~pval_type
- (("", fn) :: Ext_list.map (fun x -> "",x) args )
-
-
-let uncurry_fn_apply loc self fn args =
- generic_apply `Fn loc self fn args (fun _ obj -> obj )
-
-let property_apply loc self obj name (args : args)
- = generic_apply `PropertyFn loc self obj args
- (fun loc obj -> Exp.mk ~loc (js_property loc obj name))
-
-let method_apply loc self obj name args =
- generic_apply `Method loc self obj args
- (fun loc obj -> Exp.mk ~loc (js_property loc obj name))
-
-let generic_to_uncurry_type kind loc (mapper : Bs_ast_mapper.mapper) label
- (first_arg : Parsetree.core_type)
- (typ : Parsetree.core_type) =
- if label <> "" then
- Bs_syntaxerr.err loc Label_in_uncurried_bs_attribute;
-
- let rec aux acc (typ : Parsetree.core_type) =
- (* in general,
- we should collect [typ] in [int -> typ] before transformation,
- however: when attributes [bs] and [bs.this] found in typ,
- we should stop
- *)
- match Ast_attributes.process_attributes_rev typ.ptyp_attributes with
- | `Nothing, _ ->
- begin match typ.ptyp_desc with
- | Ptyp_arrow (label, arg, body)
- ->
- if label <> "" then
- Bs_syntaxerr.err typ.ptyp_loc Label_in_uncurried_bs_attribute;
- aux (mapper.typ mapper arg :: acc) body
- | _ -> mapper.typ mapper typ, acc
- end
- | _, _ -> mapper.typ mapper typ, acc
- in
- let first_arg = mapper.typ mapper first_arg in
- let result, rev_extra_args = aux [first_arg] typ in
- let args = List.rev rev_extra_args in
- let filter_args args =
- match args with
- | [{Parsetree.ptyp_desc =
- (Ptyp_constr ({txt = Lident "unit"}, [])
- )}]
- -> []
- | _ -> args in
- match kind with
- | `Fn ->
- let args = filter_args args in
- lift_curry_type loc args result
- | `Method ->
- let args = filter_args args in
- lift_method_type loc args result
-
- | `Method_callback
- -> lift_js_method_callback loc args result
-
-
-let to_uncurry_type =
- generic_to_uncurry_type `Fn
-let to_method_type =
- generic_to_uncurry_type `Method
-let to_method_callback_type =
- generic_to_uncurry_type `Method_callback
-
-let generic_to_uncurry_exp kind loc (self : Bs_ast_mapper.mapper) pat body
- =
- let rec aux acc (body : Parsetree.expression) =
- match Ast_attributes.process_attributes_rev body.pexp_attributes with
- | `Nothing, _ ->
- begin match body.pexp_desc with
- | Pexp_fun (label,_, arg, body)
- ->
- if label <> "" then
- Bs_syntaxerr.err loc Label_in_uncurried_bs_attribute;
- aux (self.pat self arg :: acc) body
- | _ -> self.expr self body, acc
- end
- | _, _ -> self.expr self body, acc
- in
- let first_arg = self.pat self pat in
- let () =
- match kind with
- | `Method_callback ->
- if not @@ Ast_pat.is_single_variable_pattern_conservative first_arg then
- Bs_syntaxerr.err first_arg.ppat_loc Bs_this_simple_pattern
- | _ -> ()
- in
-
- let result, rev_extra_args = aux [first_arg] body in
- let body =
- List.fold_left (fun e p -> Ast_comb.fun_no_label ~loc p e )
- result rev_extra_args in
- let len = List.length rev_extra_args in
- let arity =
- match kind with
- | `Fn ->
- begin match rev_extra_args with
- | [ p]
- ->
- Ast_pat.is_unit_cont ~yes:0 ~no:len p
-
- | _ -> len
- end
- | `Method_callback -> len in
- if arity < 10 then
- let txt =
- match kind with
- | `Fn ->
- Longident.Ldot ( Ast_literal.Lid.js_unsafe, Literals.fn_mk ^ string_of_int arity)
- | `Method_callback ->
- Longident.Ldot (Ast_literal.Lid.js_unsafe, Literals.fn_method ^ string_of_int arity) in
- Parsetree.Pexp_apply (Exp.ident {txt;loc} , ["",body])
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
- else
- let pval_prim =
- [ (match kind with
- | `Fn -> "#fn_mk"
- | `Method_callback -> "#fn_method");
- string_of_int arity] in
- let fn_type , args_type, result_type = Ast_comb.tuple_type_pair ~loc `Make arity in
- let pval_type = arrow ~loc "" fn_type (
- match kind with
- | `Fn ->
- lift_curry_type loc args_type result_type
- | `Method_callback ->
- lift_js_method_callback loc args_type result_type
- ) in
- Ast_external_mk.local_extern_cont loc ~pval_prim ~pval_type
- (fun prim -> Exp.apply ~loc prim ["", body])
-let to_uncurry_fn =
- generic_to_uncurry_exp `Fn
-let to_method_callback =
- generic_to_uncurry_exp `Method_callback
+type kind =
+ | String
+ | Var
+type error = private
+ | Invalid_code_point
+ | Unterminated_backslash
+ | Invalid_escape_code of char
+ | Invalid_hex_escape
+ | Invalid_unicode_escape
+ | Unterminated_variable
+ | Unmatched_paren
+ | Invalid_syntax_of_var of string
+(** Note the position is about code point *)
+type pos = { lnum : int ; offset : int ; byte_bol : int }
-let handle_debugger loc payload =
- if Ast_payload.as_empty_structure payload then
- Parsetree.Pexp_apply
- (Exp.ident {txt = Ldot(Ast_literal.Lid.js_unsafe, Literals.debugger ); loc},
- ["", Ast_literal.val_unit ~loc ()])
- else Location.raise_errorf ~loc "bs.raw can only be applied to a string"
+type segment = {
+ start : pos;
+ finish : pos ;
+ kind : kind;
+ content : string ;
+}
+type segments = segment list
-let handle_raw ?(check_js_regex = false) loc payload =
- begin match Ast_payload.as_string_exp ~check_js_regex payload with
- | Not_String_Lteral ->
- Location.raise_errorf ~loc
- "bs.raw can only be applied to a string"
- | Ast_payload.JS_Regex_Check_Failed ->
- Location.raise_errorf ~loc "this is an invalid js regex"
- | Correct exp ->
- let pexp_desc =
- Parsetree.Pexp_apply (
- Exp.ident {loc;
- txt =
- Ldot (Ast_literal.Lid.js_unsafe,
- Literals.raw_expr)},
- ["",exp]
- )
- in
- { exp with pexp_desc }
- end
+type cxt = {
+ mutable segment_start : pos ;
+ buf : Buffer.t ;
+ s_len : int ;
+ mutable segments : segments;
+ mutable pos_bol : int; (* record the abs position of current beginning line *)
+ mutable byte_bol : int ;
+ mutable pos_lnum : int ; (* record the line number *)
+}
-let handle_external loc x =
- let raw_exp : Ast_exp.t =
- Ast_helper.Exp.apply
- (Exp.ident ~loc
- {loc; txt = Ldot (Ast_literal.Lid.js_unsafe,
- Literals.raw_expr)})
- ~loc
- [Ext_string.empty,
- Exp.constant ~loc (Const_string (x,Some Ext_string.empty))] in
- let empty =
- Exp.ident ~loc
- {txt = Ldot (Ldot(Lident"Js", "Undefined"), "empty");loc}
- in
- let undefined_typeof =
- Exp.ident {loc ; txt = Ldot(Lident "Js","undefinedToOption")} in
- let typeof =
- Exp.ident {loc ; txt = Ldot(Lident "Js","typeof")} in
+type exn += Error of pos * pos * error
- Exp.apply ~loc undefined_typeof [
- Ext_string.empty,
- Exp.ifthenelse ~loc
- (Exp.apply ~loc
- (Exp.ident ~loc {loc ; txt = Ldot (Lident "Pervasives", "=")} )
- [
- Ext_string.empty,
- (Exp.apply ~loc typeof [Ext_string.empty,raw_exp]);
- Ext_string.empty,
- Exp.constant ~loc (Const_string ("undefined",None))
- ])
- (empty)
- (Some raw_exp)
- ]
+val empty_segment : segment -> bool
+val transform_test : string -> segment list
+val transform_interp : Location.t -> string -> Parsetree.expression
-let handle_raw_structure loc payload =
- begin match Ast_payload.as_string_exp payload with
- | Correct exp
- ->
- let pexp_desc =
- Parsetree.Pexp_apply(
- Exp.ident {txt = Ldot (Ast_literal.Lid.js_unsafe, Literals.raw_stmt); loc},
- ["",exp]) in
- Ast_helper.Str.eval
- { exp with pexp_desc }
+end = struct
+#1 "ast_utf8_string_interp.ml"
+(* 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. *)
- | Not_String_Lteral
- ->
- Location.raise_errorf ~loc "bs.raw can only be applied to a string"
- | JS_Regex_Check_Failed
- ->
- Location.raise_errorf ~loc "this is an invalid js regex"
- end
+type error =
+ | Invalid_code_point
+ | Unterminated_backslash
+ | Invalid_escape_code of char
+ | Invalid_hex_escape
+ | Invalid_unicode_escape
+ | Unterminated_variable
+ | Unmatched_paren
+ | Invalid_syntax_of_var of string
+type kind =
+ | String
+ | Var
-let ocaml_obj_as_js_object
- loc (mapper : Bs_ast_mapper.mapper)
- (self_pat : Parsetree.pattern)
- (clfs : Parsetree.class_field list) =
- let self_type_lit = "self_type" in
+(** Note the position is about code point *)
+type pos = {
+ lnum : int ;
+ offset : int ;
+ byte_bol : int (* Note it actually needs to be in sync with OCaml's lexing semantics *)
+}
- (** Attention: we should avoid type variable conflict for each method
- Since the method name is unique, there would be no conflict
- OCaml does not allow duplicate instance variable and duplicate methods,
- but it does allow duplicates between instance variable and method name,
- we should enforce such rules
- {[
- object
- val x = 3
- method x = 3
- end [@bs]
- ]} should not compile with a meaningful error message
- *)
- let generate_val_method_pair
- loc (mapper : Bs_ast_mapper.mapper)
- val_name is_mutable =
+type segment = {
+ start : pos;
+ finish : pos ;
+ kind : kind;
+ content : string ;
+}
- let result = Typ.var ~loc val_name in
- result ,
- ((val_name , [], result ) ::
- (if is_mutable then
- [val_name ^ Literals.setter_suffix,[],
- to_method_type loc mapper "" result (Ast_literal.type_unit ~loc ()) ]
- else
- []) )
- in
- (* Note mapper is only for API compatible
- * TODO: we should check label name to avoid conflict
- *)
- let self_type loc = Typ.var ~loc self_type_lit in
+type segments = segment list
- let generate_arg_type loc (mapper : Bs_ast_mapper.mapper)
- method_name arity : Ast_core_type.t =
- let result = Typ.var ~loc method_name in
- if arity = 0 then
- to_method_type loc mapper "" (Ast_literal.type_unit ~loc ()) result
- else
- let tyvars =
- Ext_list.init arity (fun i -> Typ.var ~loc (method_name ^ string_of_int i))
- in
- begin match tyvars with
- | x :: rest ->
- let method_rest =
- Ext_list.fold_right (fun v acc -> Typ.arrow ~loc "" v acc)
- rest result in
- to_method_type loc mapper "" x method_rest
- | _ -> assert false
- end in
+type cxt = {
+ mutable segment_start : pos ;
+ buf : Buffer.t ;
+ s_len : int ;
+ mutable segments : segments;
+ mutable pos_bol : int; (* record the abs position of current beginning line *)
+ mutable byte_bol : int ;
+ mutable pos_lnum : int ; (* record the line number *)
+}
- let generate_method_type
- loc
- (mapper : Bs_ast_mapper.mapper)
- ?alias_type method_name arity =
- let result = Typ.var ~loc method_name in
- let self_type =
- let v = self_type loc in
- match alias_type with
- | None -> v
- | Some ty -> Typ.alias ~loc ty self_type_lit
- in
- if arity = 0 then
- to_method_callback_type loc mapper "" self_type result
- else
- let tyvars =
- Ext_list.init arity (fun i -> Typ.var ~loc (method_name ^ string_of_int i))
- in
- begin match tyvars with
- | x :: rest ->
- let method_rest =
- Ext_list.fold_right (fun v acc -> Typ.arrow ~loc "" v acc)
- rest result in
- (to_method_callback_type loc mapper "" self_type
- (Typ.arrow ~loc "" x method_rest))
- | _ -> assert false
- end in
+type exn += Error of pos * pos * error
+
+let pp_error fmt err =
+ Format.pp_print_string fmt @@ match err with
+ | Invalid_code_point -> "Invalid code point"
+ | Unterminated_backslash -> "\\ ended unexpectedly"
+ | Invalid_escape_code c -> "Invalid escape code: " ^ String.make 1 c
+ | Invalid_hex_escape ->
+ "Invalid \\x escape"
+ | Invalid_unicode_escape -> "Invalid \\u escape"
+ | Unterminated_variable -> "$ unterminated"
+ | Unmatched_paren -> "Unmatched paren"
+ | Invalid_syntax_of_var s -> "`" ^s ^ "' is not a valid syntax of interpolated identifer"
+let valid_lead_identifier_char x =
+ match x with
+ | 'a'..'z' | '_' -> true
+ | _ -> false
+
+let valid_identifier_char x =
+ match x with
+ | 'a'..'z'
+ | 'A'..'Z'
+ | '0'..'9'
+ | '_' | '\''-> true
+ | _ -> false
+(** Invariant: [valid_lead_identifier] has to be [valid_identifier] *)
+let valid_identifier s =
+ let s_len = String.length s in
+ if s_len = 0 then false
+ else
+ valid_lead_identifier_char s.[0] &&
+ Ext_string.for_all_from s 1 valid_identifier_char
- (** we need calculate the real object type
- and exposed object type, in some cases there are equivalent
+
+let is_space x =
+ match x with
+ | ' ' | '\n' | '\t' -> true
+ | _ -> false
- for public object type its [@bs.meth] it does not depend on itself
- while for label argument it is [@bs.this] which depends internal object
- *)
- let internal_label_attr_types, public_label_attr_types =
- Ext_list.fold_right
- (fun ({pcf_loc = loc} as x : Parsetree.class_field)
- (label_attr_types, public_label_attr_types) ->
- match x.pcf_desc with
- | Pcf_method (
- label,
- public_flag,
- Cfk_concrete
- (Fresh, e))
- ->
- begin match e.pexp_desc with
- | Pexp_poly
- (({pexp_desc = Pexp_fun ("", None, pat, e)} ),
- None) ->
- let arity = Ast_pat.arity_of_fun pat e in
- let method_type =
- generate_arg_type x.pcf_loc mapper label.txt arity in
- ((label.Asttypes.txt, [], method_type) :: label_attr_types),
- (if public_flag = Public then
- (label.Asttypes.txt, [], method_type) :: public_label_attr_types
- else
- public_label_attr_types)
- | Pexp_poly( _, Some _)
- ->
- Location.raise_errorf ~loc "polymorphic type annotation not supported yet"
- | Pexp_poly (_, None) ->
- Location.raise_errorf ~loc
- "Unsupported syntax, expect syntax like `method x () = x ` "
- | _ ->
- Location.raise_errorf ~loc "Unsupported syntax in js object"
- end
- | Pcf_val (label, mutable_flag, Cfk_concrete(Fresh, val_exp)) ->
- let label_type, label_attr =
- generate_val_method_pair x.pcf_loc mapper label.txt
- (mutable_flag = Mutable )
- in
- (Ext_list.append label_attr label_attr_types, public_label_attr_types)
- | Pcf_val (label, mutable_flag, Cfk_concrete(Override, val_exp)) ->
- Location.raise_errorf ~loc "override flag not support currently"
- | Pcf_val (label, mutable_flag, Cfk_virtual _) ->
- Location.raise_errorf ~loc "virtual flag not support currently"
- | Pcf_method (_, _, Cfk_concrete(Override, _) ) ->
- Location.raise_errorf ~loc "override flag not supported"
+(**
+ FIXME: multiple line offset
+ if there is no line offset. Note {|{j||} border will never trigger a new line
+*)
+let update_position border
+ ({lnum ; offset;byte_bol } : pos)
+ (pos : Lexing.position)=
+ if lnum = 0 then
+ {pos with pos_cnum = pos.pos_cnum + border + offset }
+ (** When no newline, the column number is [border + offset] *)
+ else
+ {
+ pos with
+ pos_lnum = pos.pos_lnum + lnum ;
+ pos_bol = pos.pos_cnum + border + byte_bol;
+ pos_cnum = pos.pos_cnum + border + byte_bol + offset;
+ (** when newline, the column number is [offset] *)
+ }
+let update border
+ (start : pos)
+ (finish : pos) (loc : Location.t) : Location.t =
+ let start_pos = loc.loc_start in
+ { loc with
+ loc_start =
+ update_position border start start_pos;
+ loc_end =
+ update_position border finish start_pos
+ }
- | Pcf_method (_, _, Cfk_virtual _ )
- ->
- Location.raise_errorf ~loc "virtural method not supported"
- | Pcf_inherit _
- | Pcf_initializer _
- | Pcf_attribute _
- | Pcf_extension _
- | Pcf_constraint _ ->
- Location.raise_errorf ~loc "Only method support currently"
- ) clfs ([], []) in
- let internal_obj_type = Ast_core_type.make_obj ~loc internal_label_attr_types in
- let public_obj_type = Ast_core_type.make_obj ~loc public_label_attr_types in
- let (labels, label_types, exprs, _) =
- Ext_list.fold_right
- (fun (x : Parsetree.class_field)
- (labels,
- label_types,
- exprs, aliased ) ->
- match x.pcf_desc with
- | Pcf_method (
- label,
- _public_flag,
- Cfk_concrete
- (Fresh, e))
- ->
- begin match e.pexp_desc with
- | Pexp_poly
- (({pexp_desc = Pexp_fun ("", None, pat, e)} as f),
- None) ->
- let arity = Ast_pat.arity_of_fun pat e in
- let alias_type =
- if aliased then None
- else Some internal_obj_type in
- let label_type =
- generate_method_type ?alias_type
- x.pcf_loc mapper label.txt arity in
- (label::labels,
- label_type::label_types,
- {f with
- pexp_desc =
- let f = Ast_pat.is_unit_cont pat ~yes:e ~no:f in
- to_method_callback loc mapper self_pat f
- } :: exprs,
- true
- )
- | Pexp_poly( _, Some _)
- ->
- Location.raise_errorf ~loc
- "polymorphic type annotation not supported yet"
+(** Note [Var] kind can not be mpty *)
+let empty_segment {content } =
+ Ext_string.is_empty content
- | Pexp_poly (_, None) ->
- Location.raise_errorf
- ~loc "Unsupported syntax, expect syntax like `method x () = x ` "
- | _ ->
- Location.raise_errorf ~loc "Unsupported syntax in js object"
- end
- | Pcf_val (label, mutable_flag, Cfk_concrete(Fresh, val_exp)) ->
- let label_type, label_attr =
- generate_val_method_pair x.pcf_loc mapper label.txt
- (mutable_flag = Mutable )
- in
- (label::labels,
- label_type :: label_types,
- (mapper.expr mapper val_exp :: exprs),
- aliased
- )
- | Pcf_val (label, mutable_flag, Cfk_concrete(Override, val_exp)) ->
- Location.raise_errorf ~loc "override flag not support currently"
- | Pcf_val (label, mutable_flag, Cfk_virtual _) ->
- Location.raise_errorf ~loc "virtual flag not support currently"
- | Pcf_method (_, _, Cfk_concrete(Override, _) ) ->
- Location.raise_errorf ~loc "override flag not supported"
+let update_newline ~byte_bol loc cxt =
+ cxt.pos_lnum <- cxt.pos_lnum + 1 ;
+ cxt.pos_bol <- loc;
+ cxt.byte_bol <- byte_bol
- | Pcf_method (_, _, Cfk_virtual _ )
- ->
- Location.raise_errorf ~loc "virtural method not supported"
+let pos_error cxt ~loc error =
+ raise (Error
+ (cxt.segment_start,
+ { lnum = cxt.pos_lnum ; offset = loc - cxt.pos_bol ; byte_bol = cxt.byte_bol}, error))
+let add_var_segment cxt loc =
+ let content = Buffer.contents cxt.buf in
+ Buffer.clear cxt.buf ;
+ let next_loc = {
+ lnum = cxt.pos_lnum ; offset = loc - cxt.pos_bol ;
+ byte_bol = cxt.byte_bol } in
+ if valid_identifier content then
+ begin
+ cxt.segments <-
+ { start = cxt.segment_start;
+ finish = next_loc ;
+ kind = Var;
+ content} :: cxt.segments ;
+ cxt.segment_start <- next_loc
+ end
+ else pos_error cxt ~loc (Invalid_syntax_of_var content)
- | Pcf_inherit _
- | Pcf_initializer _
- | Pcf_attribute _
- | Pcf_extension _
- | Pcf_constraint _ ->
- Location.raise_errorf ~loc "Only method support currently"
- ) clfs ([], [], [], false) in
- let pval_type =
- Ext_list.fold_right2
- (fun label label_type acc ->
- Typ.arrow
- ~loc:label.Asttypes.loc
- label.Asttypes.txt
- label_type acc
- ) labels label_types public_obj_type in
- Ast_external_mk.local_extern_cont
- loc
- ~pval_prim:(External_process.pval_prim_of_labels labels)
- (fun e ->
- Exp.apply ~loc e
- (Ext_list.map2 (fun l expr -> l.Asttypes.txt, expr) labels exprs) )
- ~pval_type
+let add_str_segment cxt loc =
+ let content = Buffer.contents cxt.buf in
+ Buffer.clear cxt.buf ;
+ let next_loc = {
+ lnum = cxt.pos_lnum ; offset = loc - cxt.pos_bol ;
+ byte_bol = cxt.byte_bol } in
+ cxt.segments <-
+ { start = cxt.segment_start;
+ finish = next_loc ;
+ kind = String;
+ content} :: cxt.segments ;
+ cxt.segment_start <- next_loc
-let record_as_js_object
- loc
- (self : Bs_ast_mapper.mapper)
- (label_exprs : label_exprs)
- : Parsetree.expression_desc =
+
- let labels,args, arity =
- Ext_list.fold_right (fun ({Location.txt ; loc}, e) (labels,args,i) ->
- match txt with
- | Longident.Lident x ->
- ({Asttypes.loc = loc ; txt = x} :: labels, (x, self.expr self e) :: args, i + 1)
- | Ldot _ | Lapply _ ->
- Location.raise_errorf ~loc "invalid js label ") label_exprs ([],[],0) in
- Ast_external_mk.local_external loc
- ~pval_prim:(External_process.pval_prim_of_labels labels)
- ~pval_type:(Ast_core_type.from_labels ~loc arity labels)
- args
+let rec check_and_transform (loc : int ) s byte_offset ({s_len; buf} as cxt : cxt) =
+ if byte_offset = s_len then
+ add_str_segment cxt loc
+ else
+ let current_char = s.[byte_offset] in
+ match Ext_utf8.classify current_char with
+ | Single 92 (* '\\' *) ->
+ escape_code (loc + 1) s (byte_offset+1) cxt
+ | Single 34 ->
+ Buffer.add_string buf "\\\"";
+ check_and_transform (loc + 1) s (byte_offset + 1) cxt
+ | Single 39 ->
+ Buffer.add_string buf "\\'";
+ check_and_transform (loc + 1) s (byte_offset + 1) cxt
+ | Single 10 ->
+ Buffer.add_string buf "\\n";
+ let loc = loc + 1 in
+ let byte_offset = byte_offset + 1 in
+ update_newline ~byte_bol:byte_offset loc cxt ; (* Note variable could not have new-line *)
+ check_and_transform loc s byte_offset cxt
+ | Single 13 ->
+ Buffer.add_string buf "\\r";
+ check_and_transform (loc + 1) s (byte_offset + 1) cxt
+ | Single 36 -> (* $ *)
+ add_str_segment cxt loc ;
+ let offset = byte_offset + 1 in
+ if offset >= s_len then
+ pos_error ~loc cxt Unterminated_variable
+ else
+ let cur_char = s.[offset] in
+ if cur_char = '(' then
+ expect_var_paren (loc + 2) s (offset + 1) cxt
+ else
+ expect_simple_var (loc + 1) s offset cxt
+ | Single _ ->
+ Buffer.add_char buf current_char;
+ check_and_transform (loc + 1) s (byte_offset + 1) cxt
-let isCamlExceptionOrOpenVariant = Longident.parse "Caml_exceptions.isCamlExceptionOrOpenVariant"
-let obj_magic = Longident.parse "Obj.magic"
+ | Invalid
+ | Cont _ -> pos_error ~loc cxt Invalid_code_point
+ | Leading (n,_) ->
+ let i' = Ext_utf8.next s ~remaining:n byte_offset in
+ if i' < 0 then
+ pos_error cxt ~loc Invalid_code_point
+ else
+ begin
+ for k = byte_offset to i' do
+ Buffer.add_char buf s.[k];
+ done;
+ check_and_transform (loc + 1 ) s (i' + 1) cxt
+ end
+(**Lets keep identifier simple, so that we could generating a function easier in the future
+ for example
+ let f = [%fn{| $x + $y = $x_add_y |}]
+*)
+and expect_simple_var loc s offset ({buf; s_len} as cxt) =
+ let v = ref offset in
+ (* prerr_endline @@ Ext_pervasives.dump (s, has_paren, (is_space s.[!v]), !v); *)
+ if not (offset < s_len && valid_lead_identifier_char s.[offset]) then
+ pos_error cxt ~loc (Invalid_syntax_of_var Ext_string.empty)
+ else
+ begin
+ while !v < s_len && valid_identifier_char s.[!v] do (* TODO*)
+ let cur_char = s.[!v] in
+ Buffer.add_char buf cur_char;
+ incr v ;
+ done;
+ let added_length = !v - offset in
+ let loc = added_length + loc in
+ add_var_segment cxt loc ;
+ check_and_transform loc s (added_length + offset) cxt
+ end
+and expect_var_paren loc s offset ({buf; s_len} as cxt) =
+ let v = ref offset in
+ (* prerr_endline @@ Ext_pervasives.dump (s, has_paren, (is_space s.[!v]), !v); *)
+ while !v < s_len && s.[!v] <> ')' do
+ let cur_char = s.[!v] in
+ Buffer.add_char buf cur_char;
+ incr v ;
+ done;
+ let added_length = !v - offset in
+ let loc = added_length + 1 + loc in
+ if !v < s_len && s.[!v] = ')' then
+ begin
+ add_var_segment cxt loc ;
+ check_and_transform loc s (added_length + 1 + offset) cxt
+ end
+ else
+ pos_error cxt ~loc Unmatched_paren
-let rec checkCases (cases : Parsetree.case list) =
- List.iter check_case cases
-and check_case case =
- check_pat case.pc_lhs
-and check_pat (pat : Parsetree.pattern) =
- match pat.ppat_desc with
- | Ppat_construct _ -> ()
- | Ppat_or (l,r) ->
- check_pat l; check_pat r
- | _ -> Location.raise_errorf ~loc:pat.ppat_loc "Unsupported pattern in `bs.open`"
-let convertBsErrorFunction loc (self : Bs_ast_mapper.mapper) attrs (cases : Parsetree.case list ) =
- let txt = "match" in
- let txt_expr = Exp.ident ~loc {txt = Lident txt; loc} in
- let none = Exp.constraint_ ~loc
- (Exp.construct ~loc {txt = Lident "None" ; loc} None)
- (Ast_core_type.lift_option_type (Typ.any ~loc ())) in
- let () = checkCases cases in
- let cases = self.cases self cases in
- Exp.fun_ ~attrs ~loc "" None ( Pat.var ~loc {txt; loc })
- (Exp.ifthenelse
- ~loc
- (Exp.apply ~loc (Exp.ident ~loc {txt = isCamlExceptionOrOpenVariant ; loc}) ["", txt_expr ])
- (Exp.match_ ~loc
- (Exp.constraint_ ~loc
- (Exp.apply ~loc (Exp.ident ~loc {txt = obj_magic; loc}) ["", txt_expr])
- (Ast_literal.type_exn ~loc ())
- )
- (Ext_list.map_append (fun (x :Parsetree.case ) ->
- let pc_rhs = x.pc_rhs in
- let loc = pc_rhs.pexp_loc in
- {
- x with pc_rhs =
- Exp.constraint_ ~loc
- (Exp.construct ~loc {txt = Lident "Some";loc} (Some pc_rhs))
- (Ast_core_type.lift_option_type (Typ.any ~loc ()) )
- }
- ) cases
- [
- Exp.case (Pat.any ~loc ()) none
- ])
- )
- (Some none))
-
-
-end
-module Ext_ref : sig
-#1 "ext_ref.mli"
-(* 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. *)
-(** [non_exn_protect ref value f] assusme [f()]
- would not raise
-*)
+(* we share the same escape sequence with js *)
+and escape_code loc s offset ({ buf; s_len} as cxt) =
+ if offset >= s_len then
+ pos_error cxt ~loc Unterminated_backslash
+ else
+ Buffer.add_char buf '\\';
+ let cur_char = s.[offset] in
+ match cur_char with
+ | '\\'
+ | 'b'
+ | 't'
+ | 'n'
+ | 'v'
+ | 'f'
+ | 'r'
+ | '0'
+ | '$'
+ ->
+ begin
+ Buffer.add_char buf cur_char ;
+ check_and_transform (loc + 1) s (offset + 1) cxt
+ end
+ | 'u' ->
+ begin
+ Buffer.add_char buf cur_char;
+ unicode (loc + 1) s (offset + 1) cxt
+ end
+ | 'x' -> begin
+ Buffer.add_char buf cur_char ;
+ two_hex (loc + 1) s (offset + 1) cxt
+ end
+ | _ -> pos_error cxt ~loc (Invalid_escape_code cur_char)
+and two_hex loc s offset ({buf ; s_len} as cxt) =
+ if offset + 1 >= s_len then
+ pos_error cxt ~loc Invalid_hex_escape;
+ let a, b = s.[offset], s.[offset + 1] in
+ if Ext_char.valid_hex a && Ext_char.valid_hex b then
+ begin
+ Buffer.add_char buf a ;
+ Buffer.add_char buf b ;
+ check_and_transform (loc + 2) s (offset + 2) cxt
+ end
+ else
+ pos_error cxt ~loc Invalid_hex_escape
+
+
+and unicode loc s offset ({buf ; s_len} as cxt) =
+ if offset + 3 >= s_len then
+ pos_error cxt ~loc Invalid_unicode_escape
+ ;
+ let a0,a1,a2,a3 = s.[offset], s.[offset+1], s.[offset+2], s.[offset+3] in
+ if
+ Ext_char.valid_hex a0 &&
+ Ext_char.valid_hex a1 &&
+ Ext_char.valid_hex a2 &&
+ Ext_char.valid_hex a3 then
+ begin
+ Buffer.add_char buf a0;
+ Buffer.add_char buf a1;
+ Buffer.add_char buf a2;
+ Buffer.add_char buf a3;
+ check_and_transform (loc + 4) s (offset + 4) cxt
+ end
+ else
+ pos_error cxt ~loc Invalid_unicode_escape
+let transform_test s =
+ let s_len = String.length s in
+ let buf = Buffer.create (s_len * 2) in
+ let cxt =
+ { segment_start = {lnum = 0; offset = 0; byte_bol = 0};
+ buf ;
+ s_len;
+ segments = [];
+ pos_lnum = 0;
+ byte_bol = 0;
+ pos_bol = 0;
+
+ } in
+ check_and_transform 0 s 0 cxt;
+ List.rev cxt.segments
+
-val non_exn_protect : 'a ref -> 'a -> (unit -> 'b) -> 'b
-val protect : 'a ref -> 'a -> (unit -> 'b) -> 'b
+(** TODO: test empty var $() $ failure,
+ Allow identifers x.A.y *)
-val protect2 : 'a ref -> 'b ref -> 'a -> 'b -> (unit -> 'c) -> 'c
+open Ast_helper
-(** [non_exn_protect2 refa refb va vb f ]
- assume [f ()] would not raise
-*)
-val non_exn_protect2 : 'a ref -> 'b ref -> 'a -> 'b -> (unit -> 'c) -> 'c
+(** Longident.parse "Pervasives.^" *)
+let concat_ident : Longident.t =
+ Ldot (Lident "Pervasives", "^")
+ (* JS string concatMany *)
+ (* Ldot (Ldot (Lident "Js", "String"), "concat") *)
-val protect_list : ('a ref * 'a) list -> (unit -> 'b) -> 'b
+(* Longident.parse "Js.String.make" *)
+let to_string_ident : Longident.t =
+ Ldot (Ldot (Lident "Js", "String"), "make")
-end = struct
-#1 "ext_ref.ml"
-(* 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 non_exn_protect r v body =
- let old = !r in
- r := v;
- let res = body() in
- r := old;
- res
-let protect r v body =
- let old = !r in
- try
- r := v;
- let res = body() in
- r := old;
- res
- with x ->
- r := old;
- raise x
+let escaped = Some Literals.escaped_j_delimiter
-let non_exn_protect2 r1 r2 v1 v2 body =
- let old1 = !r1 in
- let old2 = !r2 in
- r1 := v1;
- r2 := v2;
- let res = body() in
- r1 := old1;
- r2 := old2;
- res
+let concat_exp
+ (a : Parsetree.expression)
+ (b : Parsetree.expression) : Parsetree.expression =
+ let loc = Bs_loc.merge a.pexp_loc b.pexp_loc in
+ Exp.apply ~loc
+ (Exp.ident { txt =concat_ident; loc})
+ ["",a ;
+ "",b]
-let protect2 r1 r2 v1 v2 body =
- let old1 = !r1 in
- let old2 = !r2 in
- try
- r1 := v1;
- r2 := v2;
- let res = body() in
- r1 := old1;
- r2 := old2;
- res
- with x ->
- r1 := old1;
- r2 := old2;
- raise x
+let border = String.length "{j|"
-let protect_list rvs body =
- let olds = Ext_list.map (fun (x,y) -> !x) rvs in
- let () = List.iter (fun (x,y) -> x:=y) rvs in
+let aux loc (segment : segment) =
+ match segment with
+ | {start ; finish; kind ; content}
+ ->
+ let loc = update border start finish loc in
+ begin match kind with
+ | String ->
+ Exp.constant
+ ~loc
+ (Const_string (content, escaped))
+ | Var ->
+ Exp.apply ~loc
+ (Exp.ident ~loc {loc ; txt = to_string_ident })
+ [
+ "",
+ Exp.ident ~loc {loc ; txt = Lident content}
+ ]
+ end
+
+
+let transform_interp loc s =
+ let s_len = String.length s in
+ let buf = Buffer.create (s_len * 2 ) in
try
- let res = body () in
- List.iter2 (fun (x,_) old -> x := old) rvs olds;
- res
- with e ->
- List.iter2 (fun (x,_) old -> x := old) rvs olds;
- raise e
+ let cxt : cxt =
+ { segment_start = {lnum = 0; offset = 0; byte_bol = 0};
+ buf ;
+ s_len;
+ segments = [];
+ pos_lnum = 0;
+ byte_bol = 0;
+ pos_bol = 0;
+
+ } in
+
+ check_and_transform 0 s 0 cxt;
+ let rev_segments = cxt.segments in
+ match rev_segments with
+ | [] ->
+ Exp.constant ~loc
+ (Const_string ("", Some Literals.escaped_j_delimiter))
+ | [ segment] ->
+ aux loc segment
+ | a::rest ->
+ List.fold_left (fun (acc : Parsetree.expression)
+ (x : segment) ->
+ concat_exp (aux loc x) acc )
+ (aux loc a) rest
+ with
+ Error (start,pos, error)
+ ->
+ Location.raise_errorf ~loc:(update border start pos loc )
+ "%a" pp_error error
end
module Ppx_entry : sig
@@ -110989,469 +111800,61 @@ end = struct
{[
let module Js =
struct unsafe_js : string -> 'a end
- in Js.unsafe_js {| blabla |}
- ]}
- The major benefit is to better error reporting (with locations).
- Otherwise
-
- {[
-
- let f u = Js.unsafe_js u
- let _ = f (1 + 2)
- ]}
- And if it is inlined some where
-*)
-
-
-
-open Ast_helper
-
-
-
-
-let record_as_js_object = ref false (* otherwise has an attribute *)
-let no_export = ref false
-
-let () =
- Ast_derive_projector.init ();
- Ast_derive_js_mapper.init ()
-
-let reset () =
- record_as_js_object := false ;
- no_export := false
-
-let rec is_simple_pattern (p : Parsetree.pattern) =
- match p.ppat_desc with
- | Ppat_any -> true
- | Ppat_var _ -> true
- | Ppat_constraint(p,_) -> is_simple_pattern p
- | _ -> false
-
-let rec destruct
- acc (e : Parsetree.expression) =
- match e.pexp_desc with
- | Pexp_open (flag, lid, cont)
- ->
- destruct
- ((flag, lid, e.pexp_loc, e.pexp_attributes) :: acc)
- cont
- | Pexp_tuple es -> Some (acc, es)
- | _ -> None
-
-let newTdcls tdcls newAttrs =
- match tdcls with
- | [ x ] ->
- [{ x with Parsetree.ptype_attributes = newAttrs}]
- | _ ->
- Ext_list.map_last
- (fun last x ->
- if last then { x with Parsetree.ptype_attributes = newAttrs} else x )
- tdcls
-(*
- [let (a,b) = M.N.(c,d) ]
- =>
- [ let a = M.N.c
- and b = M.N.d ]
-*)
-let flattern_tuple_pattern_vb
- (self : Bs_ast_mapper.mapper)
- ({pvb_loc } as vb : Parsetree.value_binding)
- acc : Parsetree.value_binding list =
- let pvb_pat = self.pat self vb.pvb_pat in
- let pvb_expr = self.expr self vb.pvb_expr in
- let pvb_attributes = self.attributes self vb.pvb_attributes in
- match destruct [] pvb_expr, pvb_pat.ppat_desc with
- | Some (wholes, es), Ppat_tuple xs
- when
- List.for_all is_simple_pattern xs &&
- Ext_list.same_length es xs
- ->
- (Ext_list.fold_right2 (fun pat exp acc->
- {Parsetree.
- pvb_pat =
- pat;
- pvb_expr =
- ( match wholes with
- | [] -> exp
- | _ ->
- List.fold_left (fun x (flag,lid,loc,attrs) ->
- {Parsetree.
- pexp_desc = Pexp_open(flag,lid,x);
- pexp_attributes = attrs;
- pexp_loc = loc
- }
- ) exp wholes) ;
- pvb_attributes;
- pvb_loc ;
- } :: acc
- ) xs es) acc
- | _ ->
- {pvb_pat ;
- pvb_expr ;
- pvb_loc ;
- pvb_attributes} :: acc
+ in Js.unsafe_js {| blabla |}
+ ]}
+ The major benefit is to better error reporting (with locations).
+ Otherwise
+ {[
+ let f u = Js.unsafe_js u
+ let _ = f (1 + 2)
+ ]}
+ And if it is inlined some where
+*)
-let process_getter_setter ~no ~get ~set
- loc name
- (attrs : Ast_attributes.t)
- (ty : Parsetree.core_type) acc =
- match Ast_attributes.process_method_attributes_rev attrs with
- | {get = None; set = None}, _ -> no ty :: acc
- | st , pctf_attributes
- ->
- let get_acc =
- match st.set with
- | Some `No_get -> acc
- | None
- | Some `Get ->
- let lift txt =
- Typ.constr ~loc {txt ; loc} [ty] in
- let (null,undefined) =
- match st with
- | {get = Some (null, undefined) } -> (null, undefined)
- | {get = None} -> (false, false ) in
- let ty =
- match (null,undefined) with
- | false, false -> ty
- | true, false -> lift Ast_literal.Lid.js_null
- | false, true -> lift Ast_literal.Lid.js_undefined
- | true , true -> lift Ast_literal.Lid.js_null_undefined in
- get ty name pctf_attributes
- :: acc
- in
- if st.set = None then get_acc
- else
- set ty (name ^ Literals.setter_suffix) pctf_attributes
- :: get_acc
+open Ast_helper
-let handle_class_type_field self
- ({pctf_loc = loc } as ctf : Parsetree.class_type_field)
- acc =
- match ctf.pctf_desc with
- | Pctf_method
- (name, private_flag, virtual_flag, ty)
- ->
- let no (ty : Parsetree.core_type) =
- let ty =
- match ty.ptyp_desc with
- | Ptyp_arrow (label, args, body)
- ->
- Ast_util.to_method_type
- ty.ptyp_loc self label args body
- | Ptyp_poly (strs, {ptyp_desc = Ptyp_arrow (label, args, body);
- ptyp_loc})
- ->
- {ty with ptyp_desc =
- Ptyp_poly(strs,
- Ast_util.to_method_type
- ptyp_loc self label args body )}
- | _ ->
- self.typ self ty
- in
- {ctf with
- pctf_desc =
- Pctf_method (name , private_flag, virtual_flag, ty)}
- in
- let get ty name pctf_attributes =
- {ctf with
- pctf_desc =
- Pctf_method (name ,
- private_flag,
- virtual_flag,
- self.typ self ty
- );
- pctf_attributes} in
- let set ty name pctf_attributes =
- {ctf with
- pctf_desc =
- Pctf_method (name,
- private_flag,
- virtual_flag,
- Ast_util.to_method_type
- loc self "" ty
- (Ast_literal.type_unit ~loc ())
- );
- pctf_attributes} in
- process_getter_setter ~no ~get ~set loc name ctf.pctf_attributes ty acc
- | Pctf_inherit _
- | Pctf_val _
- | Pctf_constraint _
- | Pctf_attribute _
- | Pctf_extension _ ->
- Bs_ast_mapper.default_mapper.class_type_field self ctf :: acc
-(*
- Attributes are very hard to attribute
- (since ptyp_attributes could happen in so many places),
- and write ppx extensions correctly,
- we can only use it locally
-*)
+let record_as_js_object = ref false (* otherwise has an attribute *)
+let no_export = ref false
+
+let () =
+ Ast_derive_projector.init ();
+ Ast_derive_js_mapper.init ()
+
+let reset () =
+ record_as_js_object := false ;
+ no_export := false
+
+
+
+let newTdcls
+ (tdcls : Parsetree.type_declaration list)
+ (newAttrs : Parsetree.attributes) : Parsetree.type_declaration list =
+ match tdcls with
+ | [ x ] ->
+ [{ x with Parsetree.ptype_attributes = newAttrs}]
+ | _ ->
+ Ext_list.map_last
+ (fun last x ->
+ if last then { x with Parsetree.ptype_attributes = newAttrs} else x )
+ tdcls
+
-let handle_core_type
- (super : Bs_ast_mapper.mapper)
- (self : Bs_ast_mapper.mapper)
- (ty : Parsetree.core_type) =
- match ty with
- | {ptyp_desc = Ptyp_extension({txt = ("bs.obj"|"obj")}, PTyp ty)}
- ->
- Ext_ref.non_exn_protect record_as_js_object true
- (fun _ -> self.typ self ty )
- | {ptyp_attributes ;
- ptyp_desc = Ptyp_arrow (label, args, body);
- (* let it go without regard label names,
- it will report error later when the label is not empty
- *)
- ptyp_loc = loc
- } ->
- begin match Ast_attributes.process_attributes_rev ptyp_attributes with
- | `Uncurry , ptyp_attributes ->
- Ast_util.to_uncurry_type loc self label args body
- | `Meth_callback, ptyp_attributes ->
- Ast_util.to_method_callback_type loc self label args body
- | `Method, ptyp_attributes ->
- Ast_util.to_method_type loc self label args body
- | `Nothing , _ ->
- Bs_ast_mapper.default_mapper.typ self ty
- end
- | {
- ptyp_desc = Ptyp_object ( methods, closed_flag) ;
- ptyp_loc = loc
- } ->
- let (+>) attr (typ : Parsetree.core_type) =
- {typ with ptyp_attributes = attr :: typ.ptyp_attributes} in
- let new_methods =
- Ext_list.fold_right (fun (label, ptyp_attrs, core_type) acc ->
- let get ty name attrs =
- let attrs, core_type =
- match Ast_attributes.process_attributes_rev attrs with
- | `Nothing, attrs -> attrs, ty (* #1678 *)
- | `Uncurry, attrs ->
- attrs, Ast_attributes.bs +> ty
- | `Method, _
- -> Location.raise_errorf ~loc "bs.get/set conflicts with bs.meth"
- | `Meth_callback, attrs ->
- attrs, Ast_attributes.bs_this +> ty
- in
- name , attrs, self.typ self core_type in
- let set ty name attrs =
- let attrs, core_type =
- match Ast_attributes.process_attributes_rev attrs with
- | `Nothing, attrs -> attrs, ty
- | `Uncurry, attrs ->
- attrs, Ast_attributes.bs +> ty
- | `Method, _
- -> Location.raise_errorf ~loc "bs.get/set conflicts with bs.meth"
- | `Meth_callback, attrs ->
- attrs, Ast_attributes.bs_this +> ty
- in
- name, attrs, Ast_util.to_method_type loc self "" core_type
- (Ast_literal.type_unit ~loc ()) in
- let no ty =
- let attrs, core_type =
- match Ast_attributes.process_attributes_rev ptyp_attrs with
- | `Nothing, attrs -> attrs, ty
- | `Uncurry, attrs ->
- attrs, Ast_attributes.bs +> ty
- | `Method, attrs ->
- attrs, Ast_attributes.bs_method +> ty
- | `Meth_callback, attrs ->
- attrs, Ast_attributes.bs_this +> ty in
- label, attrs, self.typ self core_type in
- process_getter_setter ~no ~get ~set
- loc label ptyp_attrs core_type acc
- ) methods [] in
- let inner_type =
- { ty
- with ptyp_desc = Ptyp_object(new_methods, closed_flag);
- } in
- if !record_as_js_object then
- Ast_comb.to_js_type loc inner_type
- else inner_type
- | _ -> super.typ self ty
let rec unsafe_mapper : Bs_ast_mapper.mapper =
{ Bs_ast_mapper.default_mapper with
expr = (fun self ({ pexp_loc = loc } as e) ->
match e.pexp_desc with
(** Its output should not be rewritten anymore *)
- | Pexp_extension (
- {txt = ("bs.raw" | "raw"); loc} , payload)
- ->
- Ast_util.handle_raw loc payload
- | Pexp_extension (
- {txt = ("bs.re" | "re"); loc} , payload)
- ->
- Exp.constraint_ ~loc
- (Ast_util.handle_raw ~check_js_regex:true loc payload)
- (Ast_comb.to_js_re_type loc)
- | Pexp_extension ({txt = "bs.external" | "external" ; loc }, payload) ->
- begin match Ast_payload.as_ident payload with
- | Some {txt = Lident x}
- -> Ast_util.handle_external loc x
- (* do we need support [%external gg.xx ]
-
- {[ Js.Undefined.to_opt (if Js.typeof x == "undefined" then x else Js.Undefined.empty ) ]}
- *)
-
- | None | Some _ ->
- Location.raise_errorf ~loc
- "external expects a single identifier"
- end
- | Pexp_extension ({txt = "bs.time"| "time"; loc}, payload)
- ->
- (
- match payload with
- | PStr [{pstr_desc = Pstr_eval (e,_)}] ->
- let locString =
- if loc.loc_ghost then
- "GHOST LOC"
- else
- let loc_start = loc.loc_start in
- let (file, lnum, __) = Location.get_pos_info loc_start in
- Printf.sprintf "%s %d"
- file lnum in
- let e = self.expr self e in
- Exp.sequence ~loc
- (Exp.apply ~loc
- (Exp.ident ~loc {loc;
- txt =
- Ldot (Ldot (Lident "Js", "Console"), "timeStart")
- })
- ["", Exp.constant ~loc (Const_string (locString,None))]
- )
- ( Exp.let_ ~loc Nonrecursive
- [Vb.mk ~loc (Pat.var ~loc {loc; txt = "timed"}) e ;
- ]
- (Exp.sequence ~loc
- (Exp.apply ~loc
- (Exp.ident ~loc {loc;
- txt =
- Ldot (Ldot (Lident "Js", "Console"), "timeEnd")
- })
- ["", Exp.constant ~loc (Const_string (locString,None))]
- )
- (Exp.ident ~loc {loc; txt = Lident "timed"})
- )
- )
- | _ ->
- Location.raise_errorf
- ~loc "expect a boolean expression in the payload"
- )
- | Pexp_extension({txt = "bs.assert" | "assert";loc},payload)
- ->
- (
- match payload with
- | PStr [ {pstr_desc = Pstr_eval( e,_)}] ->
-
- let locString =
- if loc.loc_ghost then
- "ASSERT FAILURE"
- else
- let loc_start = loc.loc_start in
- let (file, lnum, cnum) = Location.get_pos_info loc_start in
- let enum =
- loc.Location.loc_end.Lexing.pos_cnum -
- loc_start.Lexing.pos_cnum + cnum in
- Printf.sprintf "File %S, line %d, characters %d-%d"
- file lnum cnum enum in
- let raiseWithString locString =
- (Exp.apply ~loc
- (Exp.ident ~loc {loc; txt =
- Ldot(Ldot (Lident "Js","Exn"),"raiseError")})
- ["",
-
- Exp.constant (Const_string (locString,None))
- ])
- in
- (match e.pexp_desc with
- | Pexp_construct({txt = Lident "false"},None) ->
- (* The backend will convert [assert false] into a nop later *)
- if !Clflags.no_assert_false then
- Exp.assert_ ~loc
- (Exp.construct ~loc {txt = Lident "false";loc} None)
- else
- (raiseWithString locString)
- | Pexp_constant (Const_string (r, _)) ->
- if !Clflags.noassert then
- Exp.assert_ ~loc (Exp.construct ~loc {txt = Lident "true"; loc} None)
- (* Need special handling to make it type check*)
- else
- raiseWithString r
- | _ ->
- let e = self.expr self e in
- if !Clflags.noassert then
- (* pass down so that it still type check, but the backend will
- make it a nop
- *)
- Exp.assert_ ~loc e
- else
- Exp.ifthenelse ~loc
- (Exp.apply ~loc
- (Exp.ident {loc ; txt = Ldot(Lident "Pervasives","not")})
- ["", e]
- )
- (raiseWithString locString)
- None
- )
- | _ ->
- Location.raise_errorf
- ~loc "expect a boolean expression in the payload"
- )
- (*
- [%%bs.import Bs_internalAVLSet.(a,b,c)]
- *)
- | Pexp_extension
- ({txt = ("bs.node" | "node"); loc},
- payload)
- ->
- let strip s =
- match s with
- | "_module" -> "module"
- | x -> x in
- begin match Ast_payload.as_ident payload with
- | Some {txt = Lident
- ( "__filename"
- | "__dirname"
- | "_module"
- | "require" as name); loc}
- ->
- let exp =
- Ast_util.handle_external loc (strip name) in
- let typ =
- Ast_core_type.lift_option_type
- @@
- if name = "_module" then
- Typ.constr ~loc
- { txt = Ldot (Lident "Node", "node_module") ;
- loc} []
- else if name = "require" then
- (Typ.constr ~loc
- { txt = Ldot (Lident "Node", "node_require") ;
- loc} [] )
- else
- Ast_literal.type_string ~loc () in
- Exp.constraint_ ~loc exp typ
- | Some _ | None ->
- begin match payload with
- | PTyp _ ->
- Location.raise_errorf
- ~loc "Illegal payload, expect an expression payload instead of type payload"
- | PPat _ ->
- Location.raise_errorf
- ~loc "Illegal payload, expect an expression payload instead of pattern payload"
- | _ ->
- Location.raise_errorf
- ~loc "Illegal payload"
- end
-
- end
- |Pexp_constant (Const_string (s, (Some delim)))
+ | Pexp_extension extension ->
+ Ast_exp_extension.handle_extension record_as_js_object e self extension
+ | Pexp_constant (Const_string (s, (Some delim)))
->
if Ext_string.equal delim Literals.unescaped_js_delimiter then
let js_str = Ast_utf8_string.transform loc s in
@@ -111460,27 +111863,11 @@ let rec unsafe_mapper : Bs_ast_mapper.mapper =
else if Ext_string.equal delim Literals.unescaped_j_delimiter then
Ast_utf8_string_interp.transform_interp loc s
else e
-
- (** [bs.debugger], its output should not be rewritten any more*)
- | Pexp_extension ({txt = ("bs.debugger"|"debugger"); loc} , payload)
- -> {e with pexp_desc = Ast_util.handle_debugger loc payload}
- | Pexp_extension ({txt = ("bs.obj" | "obj"); loc}, payload)
- ->
- begin match payload with
- | PStr [{pstr_desc = Pstr_eval (e,_)}]
- ->
- Ext_ref.non_exn_protect record_as_js_object true
- (fun () -> self.expr self e )
- | _ -> Location.raise_errorf ~loc "Expect an expression here"
- end
- | Pexp_extension({txt ; loc} as lid, PTyp typ)
- when Ext_string.starts_with txt Literals.bs_deriving_dot ->
- self.expr self @@
- Ast_derive.gen_expression lid typ
-
(** End rewriting *)
| Pexp_function cases ->
- begin match Ast_attributes.process_pexp_fun_attributes_rev e.pexp_attributes with
+ begin match
+ Ast_attributes.process_pexp_fun_attributes_rev e.pexp_attributes
+ with
| `Nothing, _ ->
Bs_ast_mapper.default_mapper.expr self e
| `Exn, pexp_attributes ->
@@ -111504,102 +111891,7 @@ let rec unsafe_mapper : Bs_ast_mapper.mapper =
pexp_attributes }
end
| Pexp_apply (fn, args ) ->
- begin match fn with
- | {pexp_desc =
- Pexp_apply (
- {pexp_desc =
- Pexp_ident {txt = Lident "##" ; loc} ; _},
- [("", obj) ;
- ("", {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _} )
- ]);
- _} -> (* f##paint 1 2 *)
- {e with pexp_desc = Ast_util.method_apply loc self obj name args }
- | {pexp_desc =
- Pexp_apply (
- {pexp_desc =
- Pexp_ident {txt = Lident "#@" ; loc} ; _},
- [("", obj) ;
- ("", {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _} )
- ]);
- _} -> (* f##paint 1 2 *)
- {e with pexp_desc = Ast_util.property_apply loc self obj name args }
-
- | {pexp_desc =
- Pexp_ident {txt = Lident "##" ; loc} ; _}
- ->
- begin match args with
- | [("", obj) ;
- ("", {pexp_desc = Pexp_apply(
- {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _},
- args
- ); pexp_attributes = attrs }
- (* we should warn when we discard attributes *)
- )
- ] -> (* f##(paint 1 2 ) *)
- (* gpr#1063 foo##(bar##baz) we should rewrite (bar##baz)
- first before pattern match.
- currently the pattern match is written in a top down style.
- Another corner case: f##(g a b [@bs])
- *)
- Bs_ast_invariant.warn_unused_attributes attrs ;
- {e with pexp_desc = Ast_util.method_apply loc self obj name args}
- | [("", obj) ;
- ("",
- {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _}
- ) (* f##paint *)
- ] ->
- { e with pexp_desc =
- Ast_util.js_property loc (self.expr self obj) name
- }
-
- | _ ->
- Location.raise_errorf ~loc
- "Js object ## expect syntax like obj##(paint (a,b)) "
- end
- (* we can not use [:=] for precedece cases
- like {[i @@ x##length := 3 ]}
- is parsed as {[ (i @@ x##length) := 3]}
- since we allow user to create Js objects in OCaml, it can be of
- ref type
- {[
- let u = object (self)
- val x = ref 3
- method setX x = self##x := 32
- method getX () = !self##x
- end
- ]}
- *)
- | {pexp_desc =
- Pexp_ident {txt = Lident ("#=" )}
- } ->
- begin match args with
- | ["",
- {pexp_desc =
- Pexp_apply ({pexp_desc = Pexp_ident {txt = Lident "##"}},
- ["", obj;
- "", {pexp_desc = Pexp_ident {txt = Lident name}}
- ]
- )};
- "", arg
- ] ->
- Exp.constraint_ ~loc
- { e with
- pexp_desc =
- Ast_util.method_apply loc self obj
- (name ^ Literals.setter_suffix) ["", arg ] }
- (Ast_literal.type_unit ~loc ())
- | _ -> Bs_ast_mapper.default_mapper.expr self e
- end
- | _ ->
- begin match
- Ext_list.exclude_with_val
- Ast_attributes.is_bs e.pexp_attributes with
- | false, _ -> Bs_ast_mapper.default_mapper.expr self e
- | true, pexp_attributes ->
- {e with pexp_desc = Ast_util.uncurry_fn_apply loc self fn args ;
- pexp_attributes }
- end
- end
+ Ast_exp_apply.handle_exp_apply e self fn args
| Pexp_record (label_exprs, opt_exp) ->
if !record_as_js_object then
(match opt_exp with
@@ -111635,7 +111927,8 @@ let rec unsafe_mapper : Bs_ast_mapper.mapper =
end
| _ -> Bs_ast_mapper.default_mapper.expr self e
);
- typ = (fun self typ -> handle_core_type Bs_ast_mapper.default_mapper self typ);
+ typ = (fun self typ ->
+ Ast_core_type_class_type.handle_core_type self typ record_as_js_object);
class_type =
(fun self ({pcty_attributes; pcty_loc} as ctd) ->
match Ast_attributes.process_bs pcty_attributes with
@@ -111650,7 +111943,7 @@ let rec unsafe_mapper : Bs_ast_mapper.mapper =
{ctd with
pcty_desc = Pcty_signature {
pcsig_self ;
- pcsig_fields = Ext_list.fold_right (handle_class_type_field self) pcsig_fields []
+ pcsig_fields = Ast_core_type_class_type.handle_class_type_fields self pcsig_fields
};
pcty_attributes
}
@@ -111748,12 +112041,7 @@ let rec unsafe_mapper : Bs_ast_mapper.mapper =
| _ -> Bs_ast_mapper.default_mapper.pat self pat
end;
- value_bindings = begin fun self (vbs : Parsetree.value_binding list) ->
- (* Bs_ast_mapper.default_mapper.value_bindings self vbs *)
- List.fold_right (fun vb acc ->
- flattern_tuple_pattern_vb self vb acc
- ) vbs []
- end;
+ value_bindings = Ast_tuple_pattern_flatten.handle_value_bindings;
structure_item = begin fun self (str : Parsetree.structure_item) ->
begin match str.pstr_desc with
| Pstr_extension ( ({txt = ("bs.raw"| "raw") ; loc}, payload), _attrs)