Add more functions to the javascript interface.

compile/operators.ml

@@ -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 

compile/operators.mli

@@ -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

misc/hBig_int.mli

@@ -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

plugins/jsoo_plugin.ml

@@ -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 () =

stdlib/Js.cd

@@ -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

tests/js/main.cd

+(*
 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

tests/js/test.xhtml

@@ -10,6 +10,7 @@ Activer la console javascript avec Ctrl-Shift-I -> 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>
 <!--

types/builtin_defs.ml

@@ -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 =

types/builtin_defs.mli

@@ -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