Merge pull request #344 from ocsigen/sync_syntax

Syntax: synchronize ppx and camlp4

Author: hhugo

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

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

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$ : <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
 
@@ -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: <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
     )
   }