Skip to content

Syntax: synchronize ppx and camlp4 #344

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 4 commits into from
Jul 23, 2015
Merged

Syntax: synchronize ppx and camlp4 #344

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
fc63502
Syntax: synchronize ppx and camlp4
hhugo Jul 22, 2015
54e56d7
Syntax: indent
hhugo Jul 22, 2015
c0efaa6
Syntax: udpate test expectations
hhugo Jul 22, 2015
b3731b1
Syntax: small update
hhugo Jul 22, 2015
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion compiler/flow.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
1 change: 1 addition & 0 deletions lib/deriving_json/deriving_Json.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
231 changes: 114 additions & 117 deletions lib/ppx/ppx_js.cppo.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,6 +1,5 @@
(* For implicit optional argument elimination. Annoying with Ast_helper. *)
[@@@ocaml.warning "-48"]

open Ast_mapper
open Ast_helper
open Asttypes
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -114,7 +112,7 @@ let constrain_types ?loc obj res res_typ meth meth_typ args =
(* [($obj$ : <typ_var> 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

Expand Down Expand Up @@ -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 =
Expand Down Expand Up @@ -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
Expand All @@ -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."
Expand Down Expand Up @@ -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])
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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: <get : 'jsoo_res; ..> ]])
[]
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: <get : 'jsoo_res; ..> ]])
[]
]
]
]
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: <set : 'jsoo_arg -> unit ; ..> ]])
[]
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: <set : 'jsoo_arg -> unit ; ..> ]])
[]
]
in
[%e Js.unsafe ~loc:expr.pexp_loc "set" [ e_obj ; str @@ unescape meth ; e_value]]
]
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 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
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
)
}
Loading