Commit 6b8e4354 authored by Kim Nguyễn's avatar Kim Nguyễn
Browse files

Add more functions to the javascript interface.

parent 70208d1b
......@@ -68,8 +68,10 @@ let register_fun3 ?(ns=Ns.empty) op dom1 dom2 dom3 codom eval =
(Value.Abstraction (Some [(dom1,t2)], (fun v1 ->
Value.Abstraction (iface2, (fun v2 ->
Value.Abstraction (iface3, eval v1 v2, Value.Identity)),Value.Identity)),Value.Identity))
let register_fun_over ?(ns=Ns.empty) op iface eval =
register_cst ~ns op
(List.fold_left (fun acc (t1, t2) -> Types.(cap (arrow (cons t1) (cons t2)) acc)) Types.Arrow.any iface)
(Value.Abstraction (Some iface, eval, Value.Identity))
let register_op ?(ns=Ns.empty) op ?(expect=Types.any) typ eval =
register_unary ~ns op
......
......@@ -6,13 +6,14 @@ val register: ?ns:Ns.Uri.t ->
val register_unary: ?ns:Ns.Uri.t ->
string -> (type_fun -> type_fun) -> (Value.t -> Value.t) -> unit
val register_binary: ?ns:Ns.Uri.t ->
string -> (type_fun -> type_fun -> type_fun) -> (Value.t -> Value.t -> Value.t) -> unit
val register_fun: ?ns:Ns.Uri.t -> string -> Types.t -> Types.t -> (Value.t -> Value.t) -> unit
val register_fun2: ?ns:Ns.Uri.t -> string -> Types.t -> Types.t -> Types.t -> (Value.t -> Value.t -> Value.t) -> unit
val register_fun3: ?ns:Ns.Uri.t -> string -> Types.t -> Types.t -> Types.t -> Types.t -> (Value.t -> Value.t -> Value.t -> Value.t) -> unit
val register_fun_over: ?ns:Ns.Uri.t -> string -> (Types.t * Types.t) list -> (Value.t -> Value.t) -> unit
val register_cst: ?ns:Ns.Uri.t -> string -> Types.t -> Value.t -> unit
val register_op: ?ns:Ns.Uri.t ->
string -> ?expect:Types.t -> (Types.t -> Types.t) -> (Value.t -> Value.t) -> unit
......
......@@ -30,7 +30,7 @@ val zero : t
val one : t
val minus_one : t
val sign : t -> int
val from_int32: Int32.t -> t
val from_int64: Int64.t -> t
val to_int32: t -> Int32.t
......
......@@ -88,22 +88,32 @@ let mk_object o = Value.abstract js_object_t o
let mk_null n = Value.abstract js_null_t n
let mk_undef u = Value.abstract js_undefined_t u
let mk_fun f = Value.abstract js_fun_t f
let mk_closure to_cduce to_js f =
let open Value in
let open Builtin_defs in
let f_ = Obj.magic f in
let arity : int = Js.Unsafe.get f_ (Js.string "length") in
if arity == 0 then
Abstraction(None, (fun _ -> to_cduce (Js.Unsafe.fun_call f_ [| |])), Value.Mono)
Abstraction(Some [(nil, js_value)] , (fun _ -> to_cduce (Js.Unsafe.fun_call f_ [| |])), Value.Identity)
else
let mk_arrow n =
let rec loop i acc =
if i = 0 then acc
else
loop (i-1) Types.(arrow (cons any) (cons acc))
in
loop n js_value
in
let rec gen_closure args i x =
args.(i) <- Js.Unsafe.inject (to_js x);
if i == (arity - 1) then
to_cduce (Js.Unsafe.fun_call f_ args)
else
Abstraction (None, gen_closure args (i+1), Value.Mono)
Abstraction (Some [(Types.any, mk_arrow (arity - i - 2)) ], gen_closure args (i+1), Value.Identity)
in
let args = Array.create arity (Js.Unsafe.inject Value.Absent) in
Abstraction(None, gen_closure args 0, Value.Mono)
Abstraction(Some [(Types.any, mk_arrow (arity - 1))], gen_closure args 0, Value.Identity)
let cduce_to_js =
let open Value in
......@@ -157,15 +167,16 @@ let js_to_cduce =
let i = int_of_float f in
if f == (float_of_int i) then Value.ocaml2cduce_int i
else Value.float f
| "object" -> if Js.(instanceof v array_empty) then
let v = Obj.magic v in
| "object" -> if deep then
if Js.(instanceof v array_empty) then
let v = Obj.magic v in
Value.sequence (List.map (atomic_to_cduce false)
(Array.to_list (Js.to_array v)))
else
if deep then object_to_cduce false (Obj.magic v)
else mk_object (Obj.magic v)
| "function" -> mk_closure (atomic_to_cduce true) cduce_to_js (Obj.magic v)
(*mk_fun (Obj.magic v) *)
else
object_to_cduce false (Obj.magic v)
else mk_object (Obj.magic v)
| "function" -> if deep then mk_closure (atomic_to_cduce true) cduce_to_js (Obj.magic v)
else mk_fun (Obj.magic v)
| "undefined" | _ -> mk_undef (Obj.magic v) (* should not happen *)
)
......@@ -189,11 +200,11 @@ let js_to_cduce =
Value.vrecord !res
end
in
atomic_to_cduce true
atomic_to_cduce
let cast v =
match v with
| Value.Abstract (tag, v) when tag = js_object_t -> js_to_cduce (Obj.magic v)
| Value.Abstract (tag, v) when tag = js_object_t || tag = js_fun_t -> js_to_cduce true (Obj.magic v)
| v -> v
let register_event id event handler =
......@@ -209,19 +220,25 @@ let register_event id event handler =
elem
event
(Js.wrap_callback
(fun e -> ignore (Value.apply (Value.apply handler id) (js_to_cduce e)))
(fun e -> ignore (Value.apply (Value.apply handler id) (js_to_cduce true e )))
)
let get s =
let s = Value.cduce2ocaml_string s in
let obj = Obj.magic (Js.Unsafe.get Dom_html.window (Js.string s)) in
js_to_cduce false obj
let define_prims () =
(* define js primitives (one at the moment) *)
let () =
Js.Unsafe.eval_string "window.js_get_properties = function (o){
var res = [];
for(var n in o) res.push([ n, o[n] ]);
return res;
};"
let () =
in
let open Operators in
let open Builtin_defs in
begin
......@@ -264,6 +281,11 @@ let () =
register_fun ~ns:Ns.cduce_unsafe_ns "js_cast"
Types.any Types.empty
cast
end;
begin
register_fun ~ns:Ns.cduce_unsafe_ns "js_get"
string_latin1 js_value
get
end
let use () =
......
......@@ -6,14 +6,21 @@ type Null = cduce_:js_null
type Undefined = cduce_:js_undefined
type Function = cduce_:js_function
type Value = Object | Null | Undefined
type Value = Object | Null | Undefined | Function
type Record = { js:this = Object
.. }
.. }
let replace_inner : (Latin1 -> Latin1 -> []) = cduce_:js_replace_inner
let replace_outer : (Latin1 -> Latin1 -> []) = cduce_:js_replace_outer
let cast (Object -> Record; Null -> Null; Undefined -> Undefined) o ->
cduce_:js_cast o
let cast (Object -> Record;
Null -> Null;
Undefined -> Undefined;
Function -> (Arrow)
) o ->
cduce_:js_cast o
let get : (Latin1 -> Value) = cduce_:js_get
(*
namespace js = Js.js
let h (_ : Latin1) (ev : {..}) : [] =
......@@ -11,3 +12,18 @@ let h (_ : Latin1) (ev : {..}) : [] =
let [] = Js.register_event "tutu" ("onclick" : Latin1) h
;;
*)
let w = Js.get "Array"
let cw = Js.cast w
let [] = print (string_of w);
print "\n";
print (string_of cw);
print "\n"
let dummy (_ : []) : Js.Value = w
;;
let [] =
match cw with
((Any ->Js.Value) & f) -> let res = Js.cast (f 10) in print (string_of res)
| _ -> print "not ok\n"
\ No newline at end of file
......@@ -10,6 +10,7 @@ Activer la console javascript avec Ctrl-Shift-I -&gt; Console
<script type="text/javascript" src="../../cduce_js_runtime.js" > </script>
<script type="text/javascript" src="main.cdo.js" > </script>
<script type="text/javascript" >
function test () { };
cduce_runtime ();
</script>
<!--
......
......@@ -165,6 +165,7 @@ let js_undefined =
Types.abstract (Types.Abstracts.atom "js_undefined")
let js_function =
Types.abstract (Types.Abstracts.atom "js_function")
let js_value = Types.(cup js_function (cup js_null (cup js_undefined js_object)))
let any_attr_node = Types.cons (Types.record_fields (true,LabelMap.empty))
let any_xml,any_xml_seq,any_xml_content =
......
......@@ -56,3 +56,4 @@ val js_object : Types.t
val js_null : Types.t
val js_undefined : Types.t
val js_function : Types.t
val js_value : Types.t
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment