From fc63502324ef38f12f31ce6dc77086befa29105e Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Wed, 22 Jul 2015 17:54:18 +0100 Subject: [PATCH 1/4] Syntax: synchronize ppx and camlp4 --- compiler/flow.ml | 2 +- lib/deriving_json/deriving_Json.mli | 1 + lib/ppx/ppx_js.cppo.ml | 231 ++++++++++++++-------------- lib/syntax/pa_js.ml | 104 ++++++++----- 4 files changed, 185 insertions(+), 153 deletions(-) diff --git a/compiler/flow.ml b/compiler/flow.ml index 4f7bb1a738..d78d271574 100644 --- a/compiler/flow.ml +++ b/compiler/flow.ml @@ -237,7 +237,7 @@ let expr_escape st _x e = Array.iter (fun x -> begin match st.defs.(Var.idx x) with - | Expr (Block (_, [|k; v|])) -> + | Expr (Block (_, [|_k; v|])) -> block_escape st v | _ -> block_escape st x diff --git a/lib/deriving_json/deriving_Json.mli b/lib/deriving_json/deriving_Json.mli index 06936e316d..12d8ed5fb9 100644 --- a/lib/deriving_json/deriving_Json.mli +++ b/lib/deriving_json/deriving_Json.mli @@ -41,6 +41,7 @@ module type Json = sig val read: Deriving_Json_lexer.lexbuf -> a val to_string: a -> string val from_string: string -> a + (**/**) val match_variant: [`Cst of int | `NCst of int] -> bool val read_variant: Deriving_Json_lexer.lexbuf -> [`Cst of int | `NCst of int] -> a diff --git a/lib/ppx/ppx_js.cppo.ml b/lib/ppx/ppx_js.cppo.ml index fdbf8cde1a..a1d00019c4 100644 --- a/lib/ppx/ppx_js.cppo.ml +++ b/lib/ppx/ppx_js.cppo.ml @@ -1,6 +1,5 @@ (* For implicit optional argument elimination. Annoying with Ast_helper. *) [@@@ocaml.warning "-48"] - open Ast_mapper open Ast_helper open Asttypes @@ -52,8 +51,7 @@ let random_tvar () = let inside_Js = lazy (try - Filename.basename @@ - Filename.chop_extension !Location.input_name = "js" + Filename.basename @@ Filename.chop_extension !Location.input_name = "js" with Invalid_argument _ -> false) module Js = struct @@ -114,7 +112,7 @@ let constrain_types ?loc obj res res_typ meth meth_typ args = (* [($obj$ : Js.t)] *) let cstr = Exp.constraint_ - [%expr ([%e obj] : < .. > Js.t) ] + [%expr ([%e obj] : [%t Js.type_ "t" [ [%type: < .. > ] ] ] ) ] (Js.type_ "t" [typ_var] ) in @@ -169,15 +167,19 @@ let method_call ~loc obj meth args = let type_binders = List.map (fun (_,ev,_,(_,t)) -> (ev,t)) args in - Exp.let_ - Nonrecursive - (List.map (fun (e, _, pv, _) -> Vb.mk pv e) args) + let bindings = List.map (fun (e, _, pv, _) -> Vb.mk pv e) args in + + let body = [%expr let [%p p_obj] = [%e obj] in let [%p p_res] = [%e meth_call] in [%e constrain_types ~loc e_obj e_res ret_type meth method_type type_binders] ] + in + match bindings with + | [] -> body + | _ -> Exp.let_ Nonrecursive bindings body (** Instantiation of a class, used by new%js. *) let new_object constr args = @@ -216,7 +218,8 @@ let format_meth body = - No duplicated declaration - Only relevant declarations (val and method, for now). *) -let preprocess_literal_object fields = + +let preprocess_literal_object mappper fields = let check_name id names = if S.mem id.txt names then @@ -230,11 +233,21 @@ let preprocess_literal_object fields = let f (names, fields) exp = match exp.pcf_desc with | Pcf_val (id, mut, Cfk_concrete (bang, body)) -> + let ty = fresh_type id.loc in let names = check_name id names in - names, (`Val (id, mut, bang, body) :: fields) + let body = mappper body in + names, (`Val (id, mut, bang, body, ty) :: fields) | Pcf_method (id, priv, Cfk_concrete (bang, body)) -> let names = check_name id names in - names, (`Meth (id, priv, bang, format_meth body) :: fields) + let body = format_meth (mappper body) in + let rec create_meth_ty exp = match exp.pexp_desc with + | Pexp_fun (label,_,_,body) -> + (label, fresh_type exp.pexp_loc) :: create_meth_ty body + | _ -> [] + in + let ret_ty = fresh_type body.pexp_loc in + let fun_ty = create_meth_ty body in + names, (`Meth (id, priv, bang, body, (fun_ty, ret_ty)) :: fields) | _ -> Location.raise_errorf ~loc:exp.pcf_loc "This field is not valid inside a js literal object." @@ -271,25 +284,6 @@ to: let literal_object self_id fields = let self_type = random_tvar () in - let fields = - List.map (function - | `Val (n, mut, bang, body) -> - let ty = fresh_type n.loc in - `Val (n, mut, bang, body, ty) - | `Meth (n, priv, bang, body) -> - let rec create_meth_ty exp = match exp.pexp_desc with - | Pexp_fun (label,_,_,body) -> - (label, fresh_type exp.pexp_loc) :: create_meth_ty body - | _ -> [] - in - let ret_ty = fresh_type body.pexp_loc in - let fun_ty = create_meth_ty body in - let self_and_body = [%expr fun [%p self_id] -> [%e body]] in - `Meth (n, priv, bang, self_and_body, (fun_ty, ret_ty)) - ) - fields - in - let create_method_type = function | `Val (id, Mutable, _, _body, ty) -> (id.txt, [], Js.type_ "prop" [ty]) @@ -329,7 +323,7 @@ let literal_object self_id fields = Js.fun_ "wrap_meth_callback" [ - annotate_body ((Js.nolabel,Typ.var self_type) :: fun_ty) ret_ty body + annotate_body ((Js.nolabel,Typ.var self_type) :: fun_ty) ret_ty [%expr fun [%p self_id] -> [%e body]] ]) in @@ -365,96 +359,99 @@ let literal_object self_id fields = let js_mapper _args = { default_mapper with expr = (fun mapper expr -> + let prev_default_loc = !default_loc in default_loc := expr.pexp_loc; let { pexp_attributes; _ } = expr in - match expr with - - (* obj##.var *) - | [%expr [%e? obj] ##. [%e? meth] ] -> - let meth = exp_to_string meth in - let e_obj, p_obj = mk_id ~loc:obj.pexp_loc "jsoo_obj" in - let e_res, p_res = mk_id ~loc:expr.pexp_loc "jsoo_res" in - let new_expr = - [%expr - let [%p p_obj] = [%e obj] in - let [%p p_res] = [%e Js.unsafe "get" [e_obj ; str @@ unescape meth]] in - [%e - constrain_types - e_obj - e_res [%type: 'jsoo_res] - meth (Js.type_ "gen_prop" [[%type: ]]) - [] - ] + let new_expr = match expr with + (* obj##.var *) + | [%expr [%e? obj] ##. [%e? meth] ] -> + let obj = mapper.expr mapper obj in + let meth = exp_to_string meth in + let e_obj, p_obj = mk_id ~loc:obj.pexp_loc "jsoo_obj" in + let e_res, p_res = mk_id ~loc:expr.pexp_loc "jsoo_res" in + let new_expr = + [%expr + let [%p p_obj] = [%e obj] in + let [%p p_res] = [%e Js.unsafe "get" [e_obj ; str @@ unescape meth]] in + [%e + constrain_types + e_obj + e_res [%type: 'jsoo_res] + meth (Js.type_ "gen_prop" [[%type: ]]) + [] ] - in mapper.expr mapper { new_expr with pexp_attributes } - - (* obj##.var := value *) - | [%expr [%e? [%expr [%e? obj] ##. [%e? meth]] as res] := [%e? value]] -> - default_loc := res.pexp_loc ; - let meth = exp_to_string meth in - let e_obj, p_obj = mk_id ~loc:obj.pexp_loc "jsoo_obj" in - let e_value, p_value = mk_id ~loc:value.pexp_loc "jsoo_arg" in - let new_expr = - [%expr - let [%p p_obj] = [%e obj] - and [%p p_value] = [%e value] in - let _ = [%e - constrain_types - e_obj - e_value [%type: 'jsoo_arg] - meth (Js.type_ "gen_prop" [[%type: unit ; ..> ]]) - [] - ] - in - [%e Js.unsafe ~loc:expr.pexp_loc "set" [ e_obj ; str @@ unescape meth ; e_value]] + ] + in + mapper.expr mapper { new_expr with pexp_attributes } + + (* obj##.var := value *) + | [%expr [%e? [%expr [%e? obj] ##. [%e? meth]] as res] := [%e? value]] -> + default_loc := res.pexp_loc ; + let obj = mapper.expr mapper obj in + let value = mapper.expr mapper value in + let meth = exp_to_string meth in + let e_obj, p_obj = mk_id ~loc:obj.pexp_loc "jsoo_obj" in + let e_value, p_value = mk_id ~loc:value.pexp_loc "jsoo_arg" in + let new_expr = + [%expr + let [%p p_obj] = [%e obj] + and [%p p_value] = [%e value] in + let _ = [%e + constrain_types + e_obj + e_value [%type: 'jsoo_arg] + meth (Js.type_ "gen_prop" [[%type: unit ; ..> ]]) + [] ] - in mapper.expr mapper { new_expr with pexp_attributes } - - (* obj##meth arg1 arg2 .. *) - (* obj##(meth arg1 arg2) .. *) - | {pexp_desc = Pexp_apply - (([%expr [%e? obj] ## [%e? meth]] as expr), args); - _ - } - | [%expr [%e? obj] ## [%e? {pexp_desc = Pexp_apply((meth as expr),args); _ }]] - -> - let meth = exp_to_string meth in - let new_expr = - method_call ~loc:expr.pexp_loc obj meth args - in mapper.expr mapper { new_expr with pexp_attributes } - (* obj##meth *) - | ([%expr [%e? obj] ## [%e? meth]] as expr) -> - let meth = exp_to_string meth in - let new_expr = - method_call ~loc:expr.pexp_loc obj meth [] - in mapper.expr mapper { new_expr with pexp_attributes } - - - (* new%js constr] *) - | [%expr [%js [%e? {pexp_desc = Pexp_new constr; _}]]] -> - let new_expr = - new_object constr [] - in mapper.expr mapper { new_expr with pexp_attributes } - (* new%js constr arg1 arg2 ..)] *) - | {pexp_desc = Pexp_apply - ([%expr [%js [%e? {pexp_desc = Pexp_new constr; _}]]] - , args); - _ - } -> - let new_expr = - new_object constr args - in mapper.expr mapper { new_expr with pexp_attributes } - - - (* object%js ... end *) - | [%expr [%js [%e? {pexp_desc = Pexp_object class_struct; _} ]]] -> - let fields = preprocess_literal_object class_struct.pcstr_fields in - let new_expr = match fields with - | `Fields fields -> - literal_object class_struct.pcstr_self fields - | `Error e -> Exp.extension e - in mapper.expr mapper { new_expr with pexp_attributes } - - | _ -> default_mapper.expr mapper expr + in + [%e Js.unsafe ~loc:expr.pexp_loc "set" [ e_obj ; str @@ unescape meth ; e_value]] + ] + in + mapper.expr mapper { new_expr with pexp_attributes } + + (* obj##meth arg1 arg2 .. *) + (* obj##(meth arg1 arg2) .. *) + | {pexp_desc = Pexp_apply (([%expr [%e? obj] ## [%e? meth]] as expr), args); _} + | [%expr [%e? obj] ## [%e? {pexp_desc = Pexp_apply((meth as expr),args); _}]] + -> + let meth = exp_to_string meth in + let obj = mapper.expr mapper obj in + let args = List.map (fun (s,e) -> s, mapper.expr mapper e) args in + let new_expr = method_call ~loc:expr.pexp_loc obj meth args in + mapper.expr mapper { new_expr with pexp_attributes } + (* obj##meth *) + | ([%expr [%e? obj] ## [%e? meth]] as expr) -> + let obj = mapper.expr mapper obj in + let meth = exp_to_string meth in + let new_expr = method_call ~loc:expr.pexp_loc obj meth [] in + mapper.expr mapper { new_expr with pexp_attributes } + + (* new%js constr] *) + | [%expr [%js [%e? {pexp_desc = Pexp_new constr; _}]]] -> + let new_expr = new_object constr [] in + mapper.expr mapper { new_expr with pexp_attributes } + (* new%js constr arg1 arg2 ..)] *) + | {pexp_desc = Pexp_apply + ([%expr [%js [%e? {pexp_desc = Pexp_new constr; _}]]] + , args); _ } -> + let args = List.map (fun (s,e) -> s, mapper.expr mapper e) args in + let new_expr = + new_object constr args + in + mapper.expr mapper { new_expr with pexp_attributes } + + (* object%js ... end *) + | [%expr [%js [%e? {pexp_desc = Pexp_object class_struct; _} ]]] -> + let fields = preprocess_literal_object (mapper.expr mapper) class_struct.pcstr_fields in + let new_expr = match fields with + | `Fields fields -> + literal_object class_struct.pcstr_self fields + | `Error e -> Exp.extension e in + mapper.expr mapper { new_expr with pexp_attributes } + + | _ -> default_mapper.expr mapper expr + in + default_loc := prev_default_loc; + new_expr ) } diff --git a/lib/syntax/pa_js.ml b/lib/syntax/pa_js.ml index a684dbbbcf..2561684870 100644 --- a/lib/syntax/pa_js.ml +++ b/lib/syntax/pa_js.ml @@ -20,9 +20,9 @@ let rnd = Random.State.make [|0x313511d4|] let random_var () = - Format.sprintf "x%08Lx" (Random.State.int64 rnd 0x100000000L) + Format.sprintf "jsoo_%08Lx" (Random.State.int64 rnd 0x100000000L) let random_tvar () = - Format.sprintf "A%08Lx" (Random.State.int64 rnd 0x100000000L) + Format.sprintf "jsoo_%08Lx" (Random.State.int64 rnd 0x100000000L) module StringMap = Map.Make(String) @@ -103,11 +103,19 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct (fun arg_typ rem_typ -> <:ctyp< $arg_typ$ -> $rem_typ$ >>) args ret + let funs _loc args ret = + List.fold_right (fun x next_fun -> <:expr< fun $lid:x$ -> $next_fun$ >> ) args ret + + + let rec apply _loc init = function + | [] -> init + | x::xs -> apply _loc <:expr< $init$ $x$ >> xs let constrain_types _loc e_loc (e:string) v_loc (v:string) v_typ m_loc m m_typ args = + let typ_var = fresh_type e_loc in let cstr = - let _loc = e_loc in <:expr<($lid:e$ : $js_t_id _loc "t"$ 'B)>> in + let _loc = e_loc in <:expr<(($lid:e$ : $js_t_id _loc "t"$ $typ_var$) : $js_t_id _loc "t"$ < .. > )>> in let x = let _loc = e_loc in <:expr> in let body = let _loc = Syntax.Loc.merge e_loc m_loc in @@ -127,27 +135,30 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct let module M = struct value res = let _ = $cstr$ in - let _ = fun (x : 'B) -> $body$ in + let _ = fun (x : $typ_var$) -> $body$ in $res$; end in M.res >> let method_call _loc obj lab lab_loc args = - let args = List.map (fun e -> (e, random_var (), fresh_type _loc)) args in + let args = List.map (fun e -> + let my_var = random_var () in + let my_typ = fresh_type _loc in + (e, my_var, my_typ)) args in let ret_typ = fresh_type _loc in let method_type = arrows _loc (List.map (fun (_,_,ty) -> ty) args) <:ctyp< $js_t_id _loc "meth"$ $ret_typ$ >> in - let o = random_var () in - let res = random_var () in + let o = "jsoo_self" in + let res = "jsoo_res" in let meth_args = List.map (fun (_, x, _) -> <:expr< $js_u_id _loc "inject"$ $lid:x$ >>) args in let meth_args = make_array _loc meth_args in let o_loc = Ast.loc_of_expr obj in - List.fold_left - (fun e' (e, x, _) -> <:expr< let $lid:x$ = $e$ in $e'$>>) + let binding = List.map (fun (e, x, _) -> <:binding< $lid:x$ = $e$ >>) args in + let body = <:expr< let $lid:o$ = $obj$ in let $lid:res$ = @@ -155,7 +166,10 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct $constrain_types _loc o_loc o _loc res ret_typ lab_loc lab method_type args$ >> - args + in + match args with + | [] -> body + | _ -> <:expr< let $list:binding$ in $body$ >> let new_object _loc constructor args = let args = List.map (fun e -> (e, fresh_type _loc)) args in @@ -166,6 +180,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct (fun (e, t) -> <:expr< $js_u_id _loc "inject"$ $with_type e t$ >>) args in let args = make_array _loc args in + let x = random_var () in let constr = with_type constructor @@ -283,29 +298,48 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct let obj_type = <:ctyp< < $list:List.map create_method_type fields$ > >> in + let rec annotate_body fun_ty ret_ty body = match fun_ty, body with + | ty :: types, + (<:expr< fun $pat$ -> $body$ >>) -> + <:expr< fun ($pat$ : $ty$) -> $annotate_body types ret_ty body$ >> + | [], body -> <:expr< ($body$ : $ret_ty$) >> + | _ -> raise @@ + Invalid_argument "Inconsistent number of arguments" + in + let create_value = function | `Val {val_label=(lab,_loc); val_body=(e,_);val_typ; _} -> - <:expr< ($str:lab$, - $js_u_id _loc "inject"$ $with_type e val_typ$) >> + lab, + <:expr< $with_type e val_typ$ >> | `Meth {meth_label=(lab,_loc); meth_body=(e,_);meth_fun_typ; meth_ret_typ; _} -> - let all = arrows _loc meth_fun_typ meth_ret_typ in - let typ = <:ctyp< $js_t_id _loc "meth_callback"$ $self_typ$ $all$ >> in let e,wrapper = match self with | None -> e,"wrap_callback" - | Some self_patt -> - <:expr $e$ >>, + | Some self_pat -> + annotate_body + (self_typ :: meth_fun_typ) + meth_ret_typ + <:expr< fun $self_pat$ -> $e$ >>, "wrap_meth_callback" in - <:expr< ($str:lab$, - $js_u_id _loc "inject"$ - $with_type - (<:expr< $js_id _loc wrapper$ $e$>>) typ$) >> + lab, + <:expr< $js_id _loc wrapper$ $e$ >> in let args = List.map create_value fields in - let args = make_array _loc args in - let x = random_var () in + let make_obj = + funs _loc (List.map (fun (name, _expr) -> name) args) + (<:expr< + ( $js_u_id _loc "obj"$ + $make_array _loc (List.map (fun (name,_) -> + <:expr< ($str:name$ , $js_u_id _loc "inject"$ $lid:name$) >>) args)$ + : $js_t_id _loc "t"$ $obj_type$ as $self_typ$ ) + >>)in + let bindings = + List.map + (fun (lab, expr) -> <:binding< $lid:lab$ = $expr$ >>) + (("make_obj",make_obj)::args) + in <:expr< - let $lid:x$ : (Js.t $obj_type$ as $self_typ$) = Js.Unsafe.obj $args$ in - $lid:x$ + let $list:bindings$ in + $apply _loc <:expr< make_obj >> (List.map (fun (lab,_) -> <:expr< $lid:lab$ >>) args) $ >> @@ -321,25 +355,25 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct expr: BEFORE "." ["##" RIGHTA [ e = SELF; (lab_loc, lab) = jsmeth -> - let o = random_var () in + let o = "jsoo_obj" in let o_loc = Ast.loc_of_expr e in - let res = random_var () in + let res = "jsoo_res" in <:expr< let $lid:o$ = $e$ in let $lid:res$ = $js_u_id _loc "get"$ $lid:o$ $str:unescape lab$ in - $constrain_types _loc o_loc o _loc res <:ctyp< 'A >> - lab_loc lab <:ctyp< $js_t_id _loc "gen_prop"$ >> []$ + $constrain_types _loc o_loc o _loc res <:ctyp< 'jsoo_res >> + lab_loc lab <:ctyp< $js_t_id _loc "gen_prop"$ >> []$ >> | e1 = SELF; (lab_loc, lab) = jsmeth; "<-"; e2 = expr LEVEL "top" -> - let o = random_var () in + let o = "jsoo_obj" in let o_loc = Ast.loc_of_expr e1 in - let v = random_var () in + let v = "jsoo_arg" in <:expr< - let $lid:v$ = $e2$ in - let $lid:o$ = $e1$ in + let $lid:o$ = $e1$ + and $lid:v$ = $e2$ in let _ = $constrain_types _loc o_loc o (Ast.loc_of_expr e2) v - <:ctyp< 'A >> lab_loc lab - <:ctyp< $js_t_id _loc "gen_prop"$ unit; ..> >> + <:ctyp< 'jsoo_arg >> lab_loc lab + <:ctyp< $js_t_id _loc "gen_prop"$ unit; ..> >> []$ in $js_u_id _loc "set"$ $lid:o$ $str:unescape lab$ ($lid:v$) >> @@ -353,7 +387,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct new_object _loc e [] | "jsnew"; e = expr LEVEL "label"; "("; l = comma_expr; ")" -> new_object _loc e (parse_comma_list l) - | "jsobject"; "end" -> <:expr< ($js_u_id _loc "obj"$ [| |] : Js.t < > ) >> + | "jsobject"; "end" -> <:expr< ($js_u_id _loc "obj"$ [| |] : $js_t_id _loc "t"$ < > ) >> | "jsobject"; self = opt_class_self_patt_jsoo; l = class_structure ; "end" -> let field_list = parse_class_str_list l in let fields = List.map parse_class_item field_list in From 54e56d70d4108c0a5b68d5cfdb48efef50940d36 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Wed, 22 Jul 2015 17:58:24 +0100 Subject: [PATCH 2/4] Syntax: indent --- lib/ppx/ppx_js.cppo.ml | 176 ++++++++++++++++++++--------------------- 1 file changed, 88 insertions(+), 88 deletions(-) diff --git a/lib/ppx/ppx_js.cppo.ml b/lib/ppx/ppx_js.cppo.ml index a1d00019c4..eaef3500d3 100644 --- a/lib/ppx/ppx_js.cppo.ml +++ b/lib/ppx/ppx_js.cppo.ml @@ -363,95 +363,95 @@ let js_mapper _args = default_loc := expr.pexp_loc; let { pexp_attributes; _ } = expr in let new_expr = match expr with - (* obj##.var *) - | [%expr [%e? obj] ##. [%e? meth] ] -> - let obj = mapper.expr mapper obj in - let meth = exp_to_string meth in - let e_obj, p_obj = mk_id ~loc:obj.pexp_loc "jsoo_obj" in - let e_res, p_res = mk_id ~loc:expr.pexp_loc "jsoo_res" in - let new_expr = - [%expr - let [%p p_obj] = [%e obj] in - let [%p p_res] = [%e Js.unsafe "get" [e_obj ; str @@ unescape meth]] in - [%e - constrain_types - e_obj - e_res [%type: 'jsoo_res] - meth (Js.type_ "gen_prop" [[%type: ]]) - [] - ] - ] - in - mapper.expr mapper { new_expr with pexp_attributes } - - (* obj##.var := value *) - | [%expr [%e? [%expr [%e? obj] ##. [%e? meth]] as res] := [%e? value]] -> - default_loc := res.pexp_loc ; - let obj = mapper.expr mapper obj in - let value = mapper.expr mapper value in - let meth = exp_to_string meth in - let e_obj, p_obj = mk_id ~loc:obj.pexp_loc "jsoo_obj" in - let e_value, p_value = mk_id ~loc:value.pexp_loc "jsoo_arg" in - let new_expr = - [%expr - let [%p p_obj] = [%e obj] - and [%p p_value] = [%e value] in - let _ = [%e - constrain_types - e_obj - e_value [%type: 'jsoo_arg] - meth (Js.type_ "gen_prop" [[%type: unit ; ..> ]]) - [] - ] + (* obj##.var *) + | [%expr [%e? obj] ##. [%e? meth] ] -> + let obj = mapper.expr mapper obj in + let meth = exp_to_string meth in + let e_obj, p_obj = mk_id ~loc:obj.pexp_loc "jsoo_obj" in + let e_res, p_res = mk_id ~loc:expr.pexp_loc "jsoo_res" in + let new_expr = + [%expr + let [%p p_obj] = [%e obj] in + let [%p p_res] = [%e Js.unsafe "get" [e_obj ; str @@ unescape meth]] in + [%e + constrain_types + e_obj + e_res [%type: 'jsoo_res] + meth (Js.type_ "gen_prop" [[%type: ]]) + [] + ] + ] in - [%e Js.unsafe ~loc:expr.pexp_loc "set" [ e_obj ; str @@ unescape meth ; e_value]] - ] - in - mapper.expr mapper { new_expr with pexp_attributes } - - (* obj##meth arg1 arg2 .. *) - (* obj##(meth arg1 arg2) .. *) - | {pexp_desc = Pexp_apply (([%expr [%e? obj] ## [%e? meth]] as expr), args); _} - | [%expr [%e? obj] ## [%e? {pexp_desc = Pexp_apply((meth as expr),args); _}]] - -> - let meth = exp_to_string meth in - let obj = mapper.expr mapper obj in - let args = List.map (fun (s,e) -> s, mapper.expr mapper e) args in - let new_expr = method_call ~loc:expr.pexp_loc obj meth args in - mapper.expr mapper { new_expr with pexp_attributes } - (* obj##meth *) - | ([%expr [%e? obj] ## [%e? meth]] as expr) -> - let obj = mapper.expr mapper obj in - let meth = exp_to_string meth in - let new_expr = method_call ~loc:expr.pexp_loc obj meth [] in - mapper.expr mapper { new_expr with pexp_attributes } - - (* new%js constr] *) - | [%expr [%js [%e? {pexp_desc = Pexp_new constr; _}]]] -> - let new_expr = new_object constr [] in - mapper.expr mapper { new_expr with pexp_attributes } - (* new%js constr arg1 arg2 ..)] *) - | {pexp_desc = Pexp_apply - ([%expr [%js [%e? {pexp_desc = Pexp_new constr; _}]]] - , args); _ } -> - let args = List.map (fun (s,e) -> s, mapper.expr mapper e) args in - let new_expr = - new_object constr args + mapper.expr mapper { new_expr with pexp_attributes } + + (* obj##.var := value *) + | [%expr [%e? [%expr [%e? obj] ##. [%e? meth]] as res] := [%e? value]] -> + default_loc := res.pexp_loc ; + let obj = mapper.expr mapper obj in + let value = mapper.expr mapper value in + let meth = exp_to_string meth in + let e_obj, p_obj = mk_id ~loc:obj.pexp_loc "jsoo_obj" in + let e_value, p_value = mk_id ~loc:value.pexp_loc "jsoo_arg" in + let new_expr = + [%expr + let [%p p_obj] = [%e obj] + and [%p p_value] = [%e value] in + let _ = [%e + constrain_types + e_obj + e_value [%type: 'jsoo_arg] + meth (Js.type_ "gen_prop" [[%type: unit ; ..> ]]) + [] + ] + in + [%e Js.unsafe ~loc:expr.pexp_loc "set" [ e_obj ; str @@ unescape meth ; e_value]] + ] + in + mapper.expr mapper { new_expr with pexp_attributes } + + (* obj##meth arg1 arg2 .. *) + (* obj##(meth arg1 arg2) .. *) + | {pexp_desc = Pexp_apply (([%expr [%e? obj] ## [%e? meth]] as expr), args); _} + | [%expr [%e? obj] ## [%e? {pexp_desc = Pexp_apply((meth as expr),args); _}]] + -> + let meth = exp_to_string meth in + let obj = mapper.expr mapper obj in + let args = List.map (fun (s,e) -> s, mapper.expr mapper e) args in + let new_expr = method_call ~loc:expr.pexp_loc obj meth args in + mapper.expr mapper { new_expr with pexp_attributes } + (* obj##meth *) + | ([%expr [%e? obj] ## [%e? meth]] as expr) -> + let obj = mapper.expr mapper obj in + let meth = exp_to_string meth in + let new_expr = method_call ~loc:expr.pexp_loc obj meth [] in + mapper.expr mapper { new_expr with pexp_attributes } + + (* new%js constr] *) + | [%expr [%js [%e? {pexp_desc = Pexp_new constr; _}]]] -> + let new_expr = new_object constr [] in + mapper.expr mapper { new_expr with pexp_attributes } + (* new%js constr arg1 arg2 ..)] *) + | {pexp_desc = Pexp_apply + ([%expr [%js [%e? {pexp_desc = Pexp_new constr; _}]]] + , args); _ } -> + let args = List.map (fun (s,e) -> s, mapper.expr mapper e) args in + let new_expr = + new_object constr args + in + mapper.expr mapper { new_expr with pexp_attributes } + + (* object%js ... end *) + | [%expr [%js [%e? {pexp_desc = Pexp_object class_struct; _} ]]] -> + let fields = preprocess_literal_object (mapper.expr mapper) class_struct.pcstr_fields in + let new_expr = match fields with + | `Fields fields -> + literal_object class_struct.pcstr_self fields + | `Error e -> Exp.extension e in + mapper.expr mapper { new_expr with pexp_attributes } + + | _ -> default_mapper.expr mapper expr in - mapper.expr mapper { new_expr with pexp_attributes } - - (* object%js ... end *) - | [%expr [%js [%e? {pexp_desc = Pexp_object class_struct; _} ]]] -> - let fields = preprocess_literal_object (mapper.expr mapper) class_struct.pcstr_fields in - let new_expr = match fields with - | `Fields fields -> - literal_object class_struct.pcstr_self fields - | `Error e -> Exp.extension e in - mapper.expr mapper { new_expr with pexp_attributes } - - | _ -> default_mapper.expr mapper expr - in - default_loc := prev_default_loc; - new_expr + default_loc := prev_default_loc; + new_expr ) } From c0efaa60a3872dece6758b4fedbd1012f5aeeee7 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Wed, 22 Jul 2015 18:18:37 +0100 Subject: [PATCH 3/4] Syntax: udpate test expectations --- tests/camlp4/meth.expected | 9 +++++---- tests/camlp4/prop.expected | 5 +++-- tests/camlp4/write_prop.expected | 4 ++-- 3 files changed, 10 insertions(+), 8 deletions(-) diff --git a/tests/camlp4/meth.expected b/tests/camlp4/meth.expected index 466efeadcb..fd9848d003 100644 --- a/tests/camlp4/meth.expected +++ b/tests/camlp4/meth.expected @@ -3,7 +3,7 @@ Characters 40-43: fun (obj : int) -> obj##m();; ^^^ Error: This expression has type int but an expression was expected of type - 'a Js.t + 'jsoo_173316d7 Js.t Characters 25-28: fun (obj : < > Js.t) -> obj##m();; ^^^ @@ -14,7 +14,7 @@ Characters 43-49: ^^^^^^ Error: This expression has type float Js.prop = < get : float; set : float -> unit > Js.gen_prop - but an expression was expected of type 'a Js.meth + but an expression was expected of type 'jsoo_22f22ba7 Js.meth Characters 43-51: fun (obj : < m : float Js.meth > Js.t) -> obj##m() + 1;; ^^^^^^^^ @@ -24,12 +24,13 @@ Characters 48-54: fun (obj : < m : int -> int Js.meth > Js.t) -> obj##m() + 1;; ^^^^^^ Error: This expression has type int -> int Js.meth - but an expression was expected of type 'a Js.meth + but an expression was expected of type 'jsoo_32f94eb9 Js.meth Characters 41-47: fun (obj : < m : int Js.meth > Js.t) -> obj##m(1);; ^^^^^^ Error: This expression has type int Js.meth - but an expression was expected of type 'a -> 'b Js.meth + but an expression was expected of type + 'jsoo_776737d4 -> 'jsoo_593685be Js.meth Characters 50-59: fun (obj : < m : int -> float Js.meth > Js.t) -> obj##m(1) + 1;; ^^^^^^^^^ diff --git a/tests/camlp4/prop.expected b/tests/camlp4/prop.expected index 70f105d9d5..80a43d9cce 100644 --- a/tests/camlp4/prop.expected +++ b/tests/camlp4/prop.expected @@ -3,7 +3,7 @@ Characters 45-48: fun (obj : int) -> obj##p;; ^^^ Error: This expression has type int but an expression was expected of type - 'a Js.t + 'jsoo_32b5ee21 Js.t Characters 25-28: fun (obj : < > Js.t) -> obj##p;; ^^^ @@ -14,7 +14,8 @@ Characters 53-59: ^^^^^^ Error: This expression has type float Js.writeonly_prop = < set : float -> unit > Js.gen_prop - but an expression was expected of type < get : 'a; .. > Js.gen_prop + but an expression was expected of type + < get : 'jsoo_res; .. > Js.gen_prop The first object type has no method get Characters 43-49: fun (obj : < p : float Js.prop > Js.t) -> obj##p + 1;; diff --git a/tests/camlp4/write_prop.expected b/tests/camlp4/write_prop.expected index 9233528e9e..4ae711e7e9 100644 --- a/tests/camlp4/write_prop.expected +++ b/tests/camlp4/write_prop.expected @@ -3,7 +3,7 @@ Characters 45-48: fun (obj : int) -> obj##p <- 2;; ^^^ Error: This expression has type int but an expression was expected of type - 'a Js.t + 'jsoo_32b5ee21 Js.t Characters 25-28: fun (obj : < > Js.t) -> obj##p <- 2;; ^^^ @@ -15,7 +15,7 @@ Characters 52-58: Error: This expression has type float Js.readonly_prop = < get : float > Js.gen_prop but an expression was expected of type - < set : 'a -> unit; .. > Js.gen_prop + < set : 'jsoo_arg -> unit; .. > Js.gen_prop The first object type has no method set Characters 53-54: fun (obj : < p : float Js.prop > Js.t) -> obj##p <- 1;; From b3731b136e75bb7aa47ef0a4a31fe069a283c9dc Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Wed, 22 Jul 2015 18:24:23 +0100 Subject: [PATCH 4/4] Syntax: small update --- lib/syntax/pa_js.ml | 2 +- tests/camlp4/meth.expected | 2 +- tests/camlp4/prop.expected | 2 +- tests/camlp4/write_prop.expected | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/lib/syntax/pa_js.ml b/lib/syntax/pa_js.ml index 2561684870..d6e0a7e0bb 100644 --- a/lib/syntax/pa_js.ml +++ b/lib/syntax/pa_js.ml @@ -115,7 +115,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct _loc e_loc (e:string) v_loc (v:string) v_typ m_loc m m_typ args = let typ_var = fresh_type e_loc in let cstr = - let _loc = e_loc in <:expr<(($lid:e$ : $js_t_id _loc "t"$ $typ_var$) : $js_t_id _loc "t"$ < .. > )>> in + let _loc = e_loc in <:expr<(($lid:e$ : $js_t_id _loc "t"$ < .. >) : $js_t_id _loc "t"$ $typ_var$)>> in let x = let _loc = e_loc in <:expr> in let body = let _loc = Syntax.Loc.merge e_loc m_loc in diff --git a/tests/camlp4/meth.expected b/tests/camlp4/meth.expected index fd9848d003..f3251af426 100644 --- a/tests/camlp4/meth.expected +++ b/tests/camlp4/meth.expected @@ -3,7 +3,7 @@ Characters 40-43: fun (obj : int) -> obj##m();; ^^^ Error: This expression has type int but an expression was expected of type - 'jsoo_173316d7 Js.t + < .. > Js.t Characters 25-28: fun (obj : < > Js.t) -> obj##m();; ^^^ diff --git a/tests/camlp4/prop.expected b/tests/camlp4/prop.expected index 80a43d9cce..e713b8ab13 100644 --- a/tests/camlp4/prop.expected +++ b/tests/camlp4/prop.expected @@ -3,7 +3,7 @@ Characters 45-48: fun (obj : int) -> obj##p;; ^^^ Error: This expression has type int but an expression was expected of type - 'jsoo_32b5ee21 Js.t + < .. > Js.t Characters 25-28: fun (obj : < > Js.t) -> obj##p;; ^^^ diff --git a/tests/camlp4/write_prop.expected b/tests/camlp4/write_prop.expected index 4ae711e7e9..98e2639742 100644 --- a/tests/camlp4/write_prop.expected +++ b/tests/camlp4/write_prop.expected @@ -3,7 +3,7 @@ Characters 45-48: fun (obj : int) -> obj##p <- 2;; ^^^ Error: This expression has type int but an expression was expected of type - 'jsoo_32b5ee21 Js.t + < .. > Js.t Characters 25-28: fun (obj : < > Js.t) -> obj##p <- 2;; ^^^