Commit 5c97f22a authored by Kim Nguyễn's avatar Kim Nguyễn
Browse files

Preliminary implementation of javascript <-> cduce type translation.

parent 6fdcb42b
......@@ -332,16 +332,18 @@ CDUCEEDITOR_JS_RUNTIME = $(OBJECTS) runtime/cduce_js.cmo driver/cduceeditor_js_r
cduce_js_runtime: $(CDUCE_JS_RUNTIME)
@echo "Build $@"
$(HIDE) $(MAKE) stdlib
$(HIDE)$(CAMLC) -custom -linkpkg camlp4lib.cma $(INCLUDES) -o $@ $^ $(EXTRA_LINK_OPTS)
cduce_js_runtime.js:
@echo "Build $@"
$(HIDE) $(MAKE) NATIVE=false ML_INTERFACE=false PXP=false EXPAT=false \
CURL=false NETCLIENT=false NETCLIENT4=false NETSTRING=false \
CGI=false PXP_WLEX=false\
CGI=false PXP_WLEX=false STD_LIBDIR=/static/stdlib/ \
cduce_js_runtime
$(HIDE) mv cduce_js_runtime cduce_js_runtime.bytecode
$(HIDE) js_of_ocaml +nat.js +weak.js +toplevel.js cduce_js_runtime.bytecode
$(HIDE) js_of_ocaml --extern-fs -I . $(STDLIB_CDO:%=--file=%) \
+nat.js +weak.js +toplevel.js cduce_js_runtime.bytecode
cducetop_js_runtime: $(CDUCETOP_JS_RUNTIME)
@echo "Build $@"
......
......@@ -6,7 +6,7 @@ let init () =
Sys_js.set_channel_flusher stderr flush_to_console
let () =
let cduce_runtime () =
try
init ();
Cduce_config.init_all ();
......@@ -14,3 +14,7 @@ let () =
Cduce.run "/static/main.cdo"
with
Invalid_argument "Function 'exit' not implemented" -> ()
let () =
let cb = Js.wrap_callback cduce_runtime in
Js.Unsafe.(set global (Js.string "cduce_runtime") cb)
......@@ -115,3 +115,4 @@ let from_int32 i = cons (big_int_of_string (Int32.to_string i))
let from_int64 i = cons (big_int_of_string (Int64.to_string i))
let to_int32 i = Int32.of_string (to_string i)
let to_int64 i = Int64.of_string (to_string i)
let to_float i = float_of_big_int (get i)
......@@ -35,7 +35,7 @@ val from_int32: Int32.t -> t
val from_int64: Int64.t -> t
val to_int32: t -> Int32.t
val to_int64: t -> Int64.t
val to_float: t -> float
type ext_pool
val extract : unit -> ext_pool
val intract : ext_pool -> unit
......@@ -405,6 +405,13 @@ EXTEND Gram
| a = IDENT -> exp _loc (Var (ident a))
| "!"; e = expr -> exp _loc (get_ref e)
| i = INT -> exp _loc (Integer (Intervals.V.mk i))
| f = FLOAT -> (* TODO : add a direct representation of floats in the AST ? *)
let e1 = (Var (ident "float_of")) in
let e2 =
let s = U.mk f in
(String (U.start_index s, U.end_index s, s, cst_nil))
in
exp _loc (Apply (e1,e2))
| "`"; a = tag -> a
| c = char -> exp _loc (Char c)
]
......
......@@ -48,6 +48,7 @@ type token =
| IDENT of string
| ANY_IN_NS of string
| INT of string
| FLOAT of string
| STRING1 of string
| STRING2 of string
| PVAR of string
......@@ -66,6 +67,7 @@ module Token = struct
| KEYWORD s -> sf "KEYWORD %S" s
| IDENT s -> sf "IDENT %S" s
| INT s -> sf "INT %s" s
| FLOAT s -> sf "FLOAT %s" s
| STRING1 s -> sf "STRING \"%s\"" s
| STRING2 s -> sf "STRING \"%s\"" s
(* here it's not %S since the string is already escaped *)
......@@ -82,7 +84,7 @@ module Token = struct
let extract_string =
function
| KEYWORD s | IDENT s | INT s | STRING1 s | STRING2 s |
| KEYWORD s | IDENT s | INT s | FLOAT s | STRING1 s | STRING2 s |
ANY_IN_NS s | PVAR s -> s
| tok ->
invalid_arg ("Cannot extract a string from this token: "^
......@@ -284,7 +286,11 @@ let rec token = lexer
let s = L.utf8_sub_lexeme lexbuf 0 (L.lexeme_length lexbuf - 2) in
return lexbuf (ANY_IN_NS s)
| ".:*" ->
return lexbuf (ANY_IN_NS "")
return lexbuf (ANY_IN_NS "")
| '-'? ['0'-'9'] ['0'-'9' '_']*
('.' ['0'-'9' '_']* )
(['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']* )?
-> return lexbuf (FLOAT (L.utf8_lexeme lexbuf))
| '-'? ['0'-'9']+ ->
return lexbuf (INT (L.utf8_lexeme lexbuf))
| [ "<>=.,:;+-*/@&{}[]()|?`!" ]
......
......@@ -5,6 +5,7 @@ type token =
| IDENT of string
| ANY_IN_NS of string
| INT of string
| FLOAT of string
| STRING1 of string
| STRING2 of string
| PVAR of string
......
......@@ -19,13 +19,13 @@ let load_from_dom start_e end_e text_e id =
let elem_node = (elem :> Dom.node Js.t) in
let elem_node_opt = Js.Opt.return elem_node in
let rec parse ?(root=false) elem =
match Js.Opt.to_option elem with
match Js.Opt.to_option elem with
None -> ()
| Some elem ->
begin
let cont =
let cont =
match elem ## nodeType with
Dom.CDATA_SECTION | Dom.TEXT ->
Dom.CDATA_SECTION | Dom.TEXT ->
let txt = null_js_str (elem ## nodeValue) in
text_e txt;
ignore
......@@ -38,7 +38,7 @@ let load_from_dom start_e end_e text_e id =
let map = elem ## attributes in
let att_list = ref [] in
for i = (map ## length) - 1 downto 0 do
let att =
let att =
Js.Opt.get (map ## item (i))
(fun () -> assert false)
in
......@@ -55,7 +55,7 @@ let load_from_dom start_e end_e text_e id =
cont ()
end
in
parse ~root:true elem_node_opt
parse ~root:true elem_node_opt
let replace_inner id str =
......@@ -74,32 +74,123 @@ let replace_outer id str =
| Some elem -> elem ## outerHTML <- (Js.string str)
let simple_js_to_cduce v =
(* Pour la valeur v, si elle est changeable (string), on le fait, sinon on renvoie None *)
match Js.to_string (Js.typeof v) with
"string" -> Some (Value.ocaml2cduce_string (Js.to_string v))
| _ -> None
let js_object_t = "js_object"
let js_null_t = "js_null"
let js_undefined_t = "js_undefined"
let js_fun_t = "js_function"
let js_to_cduce e =
let js_this_label =
let open Ns in
let js_get_properties = Js.Unsafe.get Dom_html.window (Js.string "js_get_properties") in
let content = Js.Unsafe.fun_call js_get_properties [| (Js.Unsafe.inject e) |] in
let res = ref [] in
let size = Array.length content in
begin
for i = 0 to size - 1 do
let obj = content.(i) in
let n : Js.js_string Js.t = Js.Unsafe.get obj (Js.string "name") in
let v : 'a Js.t = Js.Unsafe.get obj (Js.string "value") in
match simple_js_to_cduce v with
None -> ()
| Some vcduce -> res := (Label.mk_ascii (Js.to_string n), vcduce) :: !res
done;
Value.vrecord !res
end
(* Commencer à réfléchir à js_to_cduce qui appelle la fonction, et qui, si c'est un string, fait ce qu'il faut, si c'est un number, fait ce qu'il faut, et si c'est un object, il faut que cela se rappelle récursivement pour créer un record cduce à l'intérieur du record cduce.
*)
let open Encodings in
Label.(mk (Uri.(mk (Utf8.mk "http://www.cduce.org/stdlib/Js"), Utf8.mk "this")))
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 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)
else
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)
in
let args = Array.create arity (Js.Unsafe.inject Value.Absent) in
Abstraction(None, gen_closure args 0, Value.Mono)
let cduce_to_js =
let open Value in
let rec loop v =
match Value.normalize v with
| Record (map, _) ->
let map = Imap.elements map in
let map =
List.filter (fun (i, _) ->
let ns, _ = Ns.Label.(value (from_int i)) in
Ns.(Uri.equal ns empty)) map
in
let map = List.map (fun (i, v) ->
let _, n = Ns.Label.(value (from_int i)) in
(Ident.U.to_string n, loop v)) map
in
Js.Unsafe.obj (Array.of_list map)
| Integer i -> Obj.magic (Intervals.V.to_float i)
| Abstract ((tag, v)) when tag = js_fun_t || tag = js_null_t
|| tag = js_undefined_t
|| tag = js_object_t
|| tag = "float"
-> Obj.magic v
| String_latin1 (_,_,_,_) -> Obj.magic (Js.string (cduce2ocaml_string v))
| String_utf8 (_,_,_,_) -> Obj.magic (Js.string (Ident.U.to_string (cduce2ocaml_string_utf8 v)))
| Atom (_) when Value.equal v vtrue -> Obj.magic Js._true
| Atom (_) when Value.equal v vfalse -> Obj.magic Js._false
| _ -> Obj.magic (Js.undefined)
in
loop
let js_to_cduce =
let open Ns in
let js_get_properties () = Js.Unsafe.get Dom_html.window (Js.string "js_get_properties") in
let get_properties (e : 'a Js.t) : 'b Js.t Js.js_array Js.t Js.js_array Js.t =
Js.Unsafe.fun_call (js_get_properties ()) [| (Js.Unsafe.inject e) |]
in
let rec atomic_to_cduce deep (v : 'a Js.t Js.opt Js.optdef ) =
Js.Optdef.case
v
(fun () -> mk_undef v)
(fun (v : 'a Js.t Js.opt) ->
Js.Opt.case
v
(fun () -> mk_null v)
(fun (v : 'a Js.t) ->
match Js.to_string (Js.typeof v) with
"string" -> Value.ocaml2cduce_string (Js.to_string (Obj.magic v))
| "boolean" -> Value.vbool (Js.to_bool (Obj.magic v))
| "number" -> let f : float = Obj.magic v in
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
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) *)
| "undefined" | _ -> mk_undef (Obj.magic v) (* should not happen *)
)
)
and object_to_cduce deep e =
let properties = get_properties e in
let res = ref [(js_this_label, mk_object e)] in
let size = properties ## length in
begin
for i = 0 to size - 1 do
let obj = Js.Optdef.get (Js.array_get properties i) (fun () -> assert false) in
let n : Js.js_string Js.t =
Obj.magic (Js.Optdef.get (Js.array_get obj 0) (fun () -> assert false))
in
let v : 'a Js.t Js.opt Js.optdef =
Obj.magic (Js.array_get obj 1)
in
let vcduce = atomic_to_cduce deep v in
res := (Label.mk_ascii (Js.to_string n), vcduce) :: !res
done;
Value.vrecord !res
end
in
atomic_to_cduce true
let register_event id event handler =
......@@ -107,10 +198,10 @@ let register_event id event handler =
let mlid = Value.cduce2ocaml_string id in
let mlevent = Value.cduce2ocaml_string event in
let elem = (get_document ()) ## getElementById (Js.string mlid) in
let event = Js.string ("on" ^ mlevent) in
let event = Js.string mlevent in
match Js.Opt.to_option elem with
None -> Value.failwith' ("No element with id : " ^ mlid)
| Some elem ->
| Some elem ->
Js.Unsafe.set
elem
event
......@@ -121,15 +212,11 @@ let register_event id event handler =
let define_prims () =
(* define js primitives (one at the moment) *)
Js.Unsafe.eval_string "
window.js_get_properties = function (o){
var res = [];
for(var n in o){
res.push({ 'name': n,
'value': (o[n] + '') });
};
return res;
};"
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 use () =
......@@ -143,4 +230,3 @@ let use () =
Print_xml.register_event := register_event;
main_document := Some (Dom_html.document);
define_prims()
......@@ -856,6 +856,14 @@ let ocaml2cduce_option f = function
let add v1 v2 = match (v1,v2) with
| (Integer x, Integer y) -> Integer (Intervals.V.add x y)
| (Abstract ("float", x), Integer y)
| (Integer y, Abstract ("float", x)) ->
let x : float = Obj.magic x in
float (x +. Intervals.V.to_float y)
| (Abstract ("float", x), Abstract ("float", y)) ->
let x : float = Obj.magic x in
let y : float = Obj.magic y in
float (x +. y)
| (Record (r1,sigma1), Record (r2,sigma2)) -> Record (Imap.merge r1 r2,Mono) (* XXX *)
| _ -> assert false
......
#!/bin/sh
RUNTIME=../../cduce_js_runtime.bytecode
js_of_ocaml -o main.js --extern-fs -I . --file=main.cdo --file=main.cd +nat.js +toplevel.js +weak.js "$RUNTIME"
#js_of_ocaml -o main.js --extern-fs -I . --file=main.cdo --of=main.cdo.js +nat.js +toplevel.js +weak.js "$RUNTIME"
rm -f empty.*
touch empty.ml
ocamlc -o empty.bytecode empty.ml
../../cduce --compile -I ../../stdlib main.cd
js_of_ocaml --extern-fs -I . --file=main.cdo --of=main.cdo.js empty.bytecode
namespace cduce_ = "http://www.cduce.org/#UNSAFE"
namespace js = Js.js
let fact (n : Int) : Int =
if n <= 0 then 1
else n * fact (n - 1)
let x = fact 24
let [] = print (string_of x)
let doc = load_xml "foo"
let [] = cduce_:replace_outer "foo"
(print_xml <div id="bar1">[])
(* "<div id='bar' />" *)
let [] = cduce_:replace_inner "bar1" (print_xml <div id="bar2">[])
let [] = print (print_xml doc)
let h (_ : Latin1) (ev : { .. }) : [] =
print (string_of { foo="bar" });
let h (_ : Latin1) (ev : {..}) : [] =
( match ev with
Js.MouseEvent -> print "Test ok !\n"
| _ -> print "Test not ok !\n");
print (string_of ev);
print "\n";
print "Handler appelé\n"
;;
let [] = cduce_:register_event "baz" "click" h
let [] = Js.register_event "tutu" ("onclick" : Latin1) h
;;
......@@ -4,18 +4,24 @@
</head>
<body>
Activer la console javascript avec Ctrl-Shif-I -&gt; Console
<div id="foo"> </div>
<div id="tutu" style="background:black;" onclick="" > TOTO </div>
<script type="text/javascript" src="main.js" > </script>
<script type="text/javascript" >
var logevent= function(e) {
console.log(e);
};
var e = document.getElementById("tutu");
e.onclick = logevent;
Activer la console javascript avec Ctrl-Shift-I -&gt; Console
<div id="foo"> </div>
<div id="tutu" style="background:red;" > TOTO </div>
<script type="text/javascript" src="../../cduce_js_runtime.js" > </script>
<script type="text/javascript" src="main.cdo.js" > </script>
<script type="text/javascript" >
cduce_runtime ();
</script>
<!--
<script type="text/javascript" >
var logevent= function(e) {
console.log(e);
};
var e = document.getElementById("tutu");
e.onclick = logevent;
</script>
-->
</body>
......
......@@ -10,32 +10,36 @@ let namespaces =
let types =
[
"Empty", Types.empty;
"Any", any;
"Int", int;
"Char", Types.char Chars.any;
"Byte", char_latin1;
"Atom", atom;
"Pair", Types.Product.any;
"Arrow", Types.Arrow.any;
"Record", Types.Record.any;
"String", string;
"Latin1", string_latin1;
"Bool", bool;
"Float", float;
"AnyXml", any_xml;
"Namespaces", namespaces;
"Abstract", Types.Abstract.any;
"Caml_int", caml_int;
"In_channel", in_channel;
"Out_channel", out_channel;
Ns.empty, "Empty", Types.empty;
Ns.empty, "Any", any;
Ns.empty, "Int", int;
Ns.empty, "Char", Types.char Chars.any;
Ns.empty, "Byte", char_latin1;
Ns.empty, "Atom", atom;
Ns.empty, "Pair", Types.Product.any;
Ns.empty, "Arrow", Types.Arrow.any;
Ns.empty, "Record", Types.Record.any;
Ns.empty, "String", string;
Ns.empty, "Latin1", string_latin1;
Ns.empty, "Bool", bool;
Ns.empty, "Float", float;
Ns.empty, "AnyXml", any_xml;
Ns.empty, "Namespaces", namespaces;
Ns.empty, "Abstract", Types.Abstract.any;
Ns.empty, "Caml_int", caml_int;
Ns.empty, "In_channel", in_channel;
Ns.empty, "Out_channel", out_channel;
Ns.cduce_unsafe_ns, "js_object", js_object;
Ns.cduce_unsafe_ns, "js_null", js_null;
Ns.cduce_unsafe_ns, "js_undefined", js_undefined;
Ns.cduce_unsafe_ns, "js_function", js_function;
]
let env =
List.fold_left
(fun accu (n,t) ->
let n = (Ns.empty, Ident.U.mk n) in
(fun accu (ns,n,t) ->
let n = (ns, Ident.U.mk n) in
Types.Print.register_global ("",n,[]) t;
Typer.enter_type (Ident.ident n) t accu
)
......@@ -246,37 +250,6 @@ register_fun "dump_xml_utf8"
Print_xml.dump_xml ~utf8:true !Eval.ns_table v);;
register_fun2 ~ns:Ns.cduce_unsafe_ns "replace_inner"
string_latin1 string_latin1 nil
(fun id str ->
!Print_xml.replace_inner
(Value.get_string_latin1 id)
(Value.get_string_latin1 str);
Value.nil
);;
register_fun2 ~ns:Ns.cduce_unsafe_ns "replace_outer"
string_latin1 string_latin1 nil
(fun id str ->
!Print_xml.replace_outer
(Value.get_string_latin1 id)
(Value.get_string_latin1 str);
Value.nil
);;
let htype = Types.( arrow
(cons string_latin1)
(cons (arrow (cons empty_open_record) (cons nil)))
);;
register_fun3 ~ns:Ns.cduce_unsafe_ns "register_event"
string_latin1 string_latin1 htype nil
(fun id event handler ->
!Print_xml.register_event
id
event
handler;
Value.nil);;
register_fun "print"
string_latin1 nil
......@@ -391,46 +364,83 @@ let intop f x y =
(f s t)
;;
let number_type = Types.cup float int
;;
binary_op_gen "+"
(fun arg1 arg2 constr precise ->
let t1 = arg1 (Types.cup int Types.Record.any) true in
if Types.subtype t1 int
let t1 = arg1 (Types.cup number_type Types.Record.any) true in
if Types.subtype t1 number_type
then (
let t2 = arg2 int true in
Types.interval
(intop Intervals.add (Types.Int.get t1) (Types.Int.get t2))
let t2 = arg2 number_type true in
if Types.subtype t1 int && Types.subtype t2 int then
Types.interval
(intop Intervals.add (Types.Int.get t1) (Types.Int.get t2))
else float
)
else if Types.subtype t1 Types.Record.any
then (
let t2 = arg2 Types.Record.any true in
Types.Record.merge t1 t2
)
else raise (Typer.Error "The first argument mixes integers and records"))
else raise (Typer.Error "The first argument mixes numbers and records"))
Value.add;;
binary_op "-"
int int
(fun t1 t2 ->
Types.interval
(intop Intervals.sub (Types.Int.get t1) (Types.Int.get t2)))
(fun v1 v2 -> match (v1,v2) with
| (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.sub x y)
| _ -> assert false);;
number_type number_type
(fun t1 t2 ->
if Types.subtype t1 int && Types.subtype t2 int then
Types.interval
(intop Intervals.sub (Types.Int.get t1) (Types.Int.get t2))
else float
)
(fun v1 v2 -> match (v1,v2) with
| (Value.Abstract("float", x), Value.Abstract("float", y)) ->
Value.float ((Obj.magic x) -. (Obj.magic y))
| (Value.Integer x, Value.Abstract("float", y)) ->
Value.float ((Intervals.V.to_float x) -. Obj.magic y)
| (Value.Abstract("float", x), Value.Integer y) ->
Value.float ((Obj.magic x) -. Intervals.V.to_float y)
| (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.sub x y)
| _ -> assert false);;
binary_op "*"
int int
(fun t1 t2 ->
Types.interval
(intop Intervals.mul (Types.Int.get t1) (Types.Int.get t2)))
(fun v1 v2 -> match (v1,v2) with
| (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.mult x y)
| _ -> assert false);;
number_type number_type
(fun t1 t2 ->
if Types.subtype t1 int && Types.subtype t2 int then
Types.interval
(intop Intervals.mul (Types.Int.get t1) (Types.Int.get t2))
else float
)
(fun v1 v2 -> match (v1,v2) with
| (Value.Abstract("float", x), Value.Abstract("float", y)) ->
Value.float ((Obj.magic x) *. (Obj.magic y))
| (Value.Integer x, Value.Abstract("float", y)) ->
Value.float ((Intervals.V.to_float x) *. Obj.magic y)
| (Value.Abstract("float", x), Value.Integer y) ->