Continue js syntax example.

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@12767 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

2 files changed, 39 insertions, 9 deletions

diff --git a/experimental/frisch/js_syntax.ml b/experimental/frisch/js_syntax.ml
index 38fe50a15..63ea5a700 100644
--- a/experimental/frisch/js_syntax.ml
+++ b/experimental/frisch/js_syntax.ml
@@ -4,14 +4,17 @@ open Location
 open Parsetree
 open Longident
 
+let constr1 c l = T.constr (mknoloc (Longident.parse c)) l
+let apply1 f l = E.apply (E.lid f) l
+let annot e t = E.constraint_ e (Some t) None
+
+
 let rnd = Random.State.make [|0x513511d4|]
 let random_var () =
   Format.sprintf "a%08Lx" (Random.State.int64 rnd 0x100000000L)
 
 let fresh_type () = T.var (random_var ())
 
-let js_t t = T.constr (mknoloc (Longident.parse "Js.t")) [t]
-let js_gen_prop t = T.constr (mknoloc (Longident.parse "Js.gen_prop")) [t]
 
 let unescape lab =
   assert (lab <> "");
@@ -25,13 +28,11 @@ let unescape lab =
   with Not_found ->
     lab
 
-let annot e t = E.constraint_ e (Some t) None
-
 let access_object loc e m m_typ f =
   let open E in
   let x = random_var () in
   let obj_type = random_var () in
-  let obj = annot e T.(js_t (alias (object_ [field_var ()]) obj_type)) in
+  let obj = annot e T.(constr1 "Js.t" [alias (object_ [field_var ()]) obj_type]) in
   let y = random_var () in
   let o = annot (ident (mknoloc (Lident y))) (T.var obj_type) in
   let body = annot (send o m) m_typ in
@@ -39,6 +40,22 @@ let access_object loc e m m_typ f =
   let e = let_ Nonrecursive [P.var (mknoloc x), obj; P.any (), constr] (f (E.ident (mknoloc (Lident x)))) in
   (set_loc loc) # expr e
 
+let method_call loc obj meth args =
+  let args = List.map (fun e -> (e, fresh_type ())) args in
+  let ret_type = fresh_type () in
+  let method_type =
+    List.fold_right
+      (fun (_, arg_ty) rem_ty -> T.arrow "" arg_ty rem_ty)
+      args (constr1 "Js.meth" [ret_type])
+  in
+  access_object loc obj meth method_type
+    (fun x ->
+      let args =
+        List.map (fun (e, t) -> apply1 "Js.Unsafe.inject" [annot e t]) args
+      in
+      annot E.(apply1 "Js.Unsafe.meth_call" [x; strconst (unescape meth); array args]) ret_type
+    )
+
 
 let mapper =
   object(this)
@@ -55,11 +72,11 @@ let mapper =
           let loc = e.pexp_loc in
           let o = this # expr o in
           let prop_type = fresh_type () in
-          let meth_type = js_gen_prop (T.(object_ [field "get" prop_type; field_var ()])) in
+          let meth_type = constr1 "Js.gen_prop" [T.(object_ [field "get" prop_type; field_var ()])] in
           access_object loc o meth meth_type
             (fun x ->
               let open E in
-              annot (apply (lid "Js.Unsafe.get") [x; strconst (unescape meth)]) prop_type
+              annot (apply1 "Js.Unsafe.get" [x; strconst (unescape meth)]) prop_type
             )
 
       | Pexp_setfield (o, {txt = Lident meth}, e) when js ->
@@ -67,13 +84,18 @@ let mapper =
           let o = this # expr o in
           let e = this # expr e in
           let prop_type = fresh_type () in
-          let meth_type = js_gen_prop (T.(object_ [field "set" (arrow "" prop_type (constr (mknoloc (Lident "unit")) [])); field_var ()])) in
+          let meth_type = constr1 "Js.gen_prop" [T.(object_ [field "set" (arrow "" prop_type (constr (mknoloc (Lident "unit")) [])); field_var ()])] in
           access_object loc o meth meth_type
             (fun x ->
               let open E in
-              apply (lid "Js.Unsafe.set") [x; strconst (unescape meth); annot e prop_type]
+              apply1 "Js.Unsafe.set" [x; strconst (unescape meth); annot e prop_type]
             )
 
+      | Pexp_apply ({pexp_desc = Pexp_send (o, meth); pexp_loc = loc}, args) when js ->
+          method_call loc o meth (List.map snd args)
+      | Pexp_send (o, meth) when js ->
+          method_call e.pexp_loc o meth []
+
       | _ ->
           super # expr e
   end
diff --git a/experimental/frisch/test_js.ml b/experimental/frisch/test_js.ml
index 1594d4042..0c6155cb7 100644
--- a/experimental/frisch/test_js.ml
+++ b/experimental/frisch/test_js.ml
@@ -1,9 +1,13 @@
 module Js = struct
   type +'a t
   type +'a gen_prop
+  type +'a meth
   module Unsafe = struct
+    type any
     let get (_o : 'a t) (_meth : string) = assert false
     let set (_o : 'a t) (_meth : string) (_v : 'b) = ()
+    let meth_call (_ : 'a) (_ : string) (_ : any array) : 'b = assert false
+    let inject _ : any = assert false
   end
 end
 
@@ -12,3 +16,7 @@ let foo1 o =
 
 let foo2 o =
   JS.(o.x <- o.x + 1)
+
+
+let foo3 o a =
+  JS.(o#x) + JS.(o#y 1 a)