Polishing.

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

1 files changed, 35 insertions, 29 deletions

diff --git a/experimental/frisch/js_syntax.ml b/experimental/frisch/js_syntax.ml
index 63ea5a700..e589f4600 100644
--- a/experimental/frisch/js_syntax.ml
+++ b/experimental/frisch/js_syntax.ml
@@ -1,21 +1,32 @@
+(* This example shows how the AST mapping approach could be used
+   instead of Camlp4 in order to give a nice syntax for js_of_ocaml
+   (properties and method calls). The code below overloads regular
+   syntax for field projection and assignment for Javascript
+   properties, and (currified) method call for Javascript method
+   calls. This is enabled by a fake local open on pseudo module JS,
+   i.e.  in a scope like "JS.(...)" or "let open JS in ...".
+ *)
+
 open Asttypes
 open Ast_mapper
 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
+(* A few local helper functions to simplify the creation of AST nodes. *)
+let constr_ c l = T.constr (mknoloc (Longident.parse c)) l
+let apply_ f l = E.apply (E.lid f) l
+let oobject l = T.object_ (List.map (fun (s, t) -> T.field s t) l @ [T.field_var ()])
+let eident x = E.ident (mknoloc (Lident x))
+let pvar x = P.var (mknoloc x)
 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 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 unescape lab =
   assert (lab <> "");
   let lab =
@@ -28,16 +39,17 @@ let unescape lab =
   with Not_found ->
     lab
 
+let method_literal meth = E.strconst (unescape meth)
+
 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.(constr1 "Js.t" [alias (object_ [field_var ()]) obj_type]) in
+  let obj = annot e T.(constr_ "Js.t" [alias (oobject []) 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
-  let constr = func "" None [P.var (mknoloc y), body] in
-  let e = let_ Nonrecursive [P.var (mknoloc x), obj; P.any (), constr] (f (E.ident (mknoloc (Lident x)))) in
+  let o = annot (eident y) (T.var obj_type) in
+  let constr = func "" None [pvar y, annot (send o m) m_typ] in
+  let e = let_ Nonrecursive [pvar x, obj; P.any (), constr] (f (eident x)) in
   (set_loc loc) # expr e
 
 let method_call loc obj meth args =
@@ -46,14 +58,15 @@ let method_call loc obj meth args =
   let method_type =
     List.fold_right
       (fun (_, arg_ty) rem_ty -> T.arrow "" arg_ty rem_ty)
-      args (constr1 "Js.meth" [ret_type])
+      args
+      (constr_ "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
+        List.map (fun (e, t) -> apply_ "Js.Unsafe.inject" [annot e t]) args
       in
-      annot E.(apply1 "Js.Unsafe.meth_call" [x; strconst (unescape meth); array args]) ret_type
+      annot (apply_ "Js.Unsafe.meth_call" [x; method_literal meth; E.array args]) ret_type
     )
 
 
@@ -64,37 +77,30 @@ let mapper =
     val js = false
 
     method! expr e =
+      let loc = e.pexp_loc in
       match e.pexp_desc with
       | Pexp_open ({txt = Lident "JS"}, e) ->
           {< js = true >} # expr e
 
       | Pexp_field (o, {txt = Lident meth}) when js ->
-          let loc = e.pexp_loc in
           let o = this # expr o in
           let prop_type = fresh_type () in
-          let meth_type = constr1 "Js.gen_prop" [T.(object_ [field "get" prop_type; field_var ()])] in
+          let meth_type = constr_ "Js.gen_prop" [oobject ["get", prop_type]] in
           access_object loc o meth meth_type
-            (fun x ->
-              let open E in
-              annot (apply1 "Js.Unsafe.get" [x; strconst (unescape meth)]) prop_type
-            )
+            (fun x -> annot (apply_ "Js.Unsafe.get" [x; method_literal meth]) prop_type)
 
       | Pexp_setfield (o, {txt = Lident meth}, e) when js ->
-          let loc = e.pexp_loc in
-          let o = this # expr o in
-          let e = this # expr e in
+          let o = this # expr o and e = this # expr e in
           let prop_type = fresh_type () in
-          let meth_type = constr1 "Js.gen_prop" [T.(object_ [field "set" (arrow "" prop_type (constr (mknoloc (Lident "unit")) [])); field_var ()])] in
+          let meth_type = constr_ "Js.gen_prop" [oobject ["set", T.arrow "" prop_type (constr_ "unit" [])]] in
           access_object loc o meth meth_type
-            (fun x ->
-              let open E in
-              apply1 "Js.Unsafe.set" [x; strconst (unescape meth); annot e prop_type]
-            )
+            (fun x -> apply_ "Js.Unsafe.set" [x; method_literal 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 []
+          method_call loc o meth []
 
       | _ ->
           super # expr e