1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
|
(* 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 under the scope of the [%js ...] extension:
Get property: [%js o.x]
Set property: [%js o.x <- e]
Method call: [%js o#x e1 e2]
*)
open Asttypes
open! Location
open Parsetree
open Longident
open Ast_helper
open Ast_helper.Convenience
(* A few local helper functions to simplify the creation of AST nodes. *)
let apply_ f l = app (evar f) l
let oobject l = Typ.object_ l Open
let annot e t = Exp.constraint_ e t
let rnd = Random.State.make [|0x513511d4|]
let random_var () = Format.sprintf "a%08Lx" (Random.State.int64 rnd 0x100000000L : Int64.t)
let fresh_type () = Typ.var (random_var ())
let unescape lab =
assert (lab <> "");
let lab =
if lab.[0] = '_' then String.sub lab 1 (String.length lab - 1) else lab
in
try
let i = String.rindex lab '_' in
if i = 0 then raise Not_found;
String.sub lab 0 i
with Not_found ->
lab
let method_literal meth = str (unescape meth)
let access_object loc e m m_typ f =
let open Exp in
with_default_loc loc
(fun () ->
let x = random_var () in
let obj_type = random_var () in
let obj = annot e Typ.(tconstr "Js.t" [alias (oobject []) obj_type]) in
let y = random_var () in
let o = annot (evar y) (Typ.var obj_type) in
let constr = lam (pvar y) (annot (send o m) m_typ) in
let_in [Vb.mk (pvar x) obj; Vb.mk (Pat.any ()) constr] (f (evar x))
)
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 -> Typ.arrow "" arg_ty rem_ty)
args
(tconstr "Js.meth" [ret_type])
in
access_object loc obj meth method_type
(fun x ->
let args =
List.map (fun (e, t) -> apply_ "Js.Unsafe.inject" [annot e t]) args
in
annot (apply_ "Js.Unsafe.meth_call" [x; method_literal meth; Exp.array args]) ret_type
)
let mapper _args =
let open Ast_mapper in
let rec mk ~js =
let super = default_mapper in
let expr this e =
let loc = e.pexp_loc in
match e.pexp_desc with
| Pexp_extension({txt="js";_}, PStr [{pstr_desc=Pstr_eval (e, _);_}]) ->
let this = mk ~js:true in this.expr this e
| Pexp_field (o, {txt = Lident meth; loc = _}) when js ->
let o = this.expr this o in
let prop_type = fresh_type () in
let meth_type = tconstr "Js.gen_prop" [oobject ["get", prop_type]] in
access_object loc o meth meth_type
(fun x -> annot (apply_ "Js.Unsafe.get" [x; method_literal meth]) prop_type)
| Pexp_setfield (o, {txt = Lident meth; loc = _}, e) when js ->
let o = this.expr this o and e = this.expr this e in
let prop_type = fresh_type () in
let meth_type = tconstr "Js.gen_prop" [oobject ["set", Typ.arrow "" prop_type (tconstr "unit" [])]] in
access_object loc o meth meth_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 (this.expr this) (List.map snd args))
| Pexp_send (o, meth) when js ->
method_call loc o meth []
| _ ->
super.expr this e
in
{super with expr}
in
mk ~js:false
let () = Ast_mapper.run_main mapper
|
