Permalink
Browse files

because ocamljs bool is now javascript bool, can no longer marshal he…

…ap rep regardless of type.

also fixed broken array and ref cases in unmarshal.
  • Loading branch information...
1 parent c089133 commit 7d3d47106d838c7d482d52e9e036f00188d659ed Jake Donham committed Jul 20, 2010
@@ -28,10 +28,15 @@ let _loc = Camlp4.PreCast.Loc.ghost
module G = Gen_common
-let to_ id = "to_" ^ id
+let s_arg id = id ^ "'arg"
+let s_res id = id ^ "'res"
+let s_res0 id = id ^ "'res0"
+
let long_to_ id = "orpc_js_aux_to_" ^ id
+let long_of_ id = "orpc_js_aux_of_" ^ id
-let s_arg id = id ^ "'arg"
+let to_ id = "to_" ^ id
+let of_ id = "of_" ^ id
let gen_sig_typedef ?(qual_id=G.id) ds =
<:sig_item< $list:
@@ -45,6 +50,12 @@ let gen_sig_typedef ?(qual_id=G.id) ds =
$G.arrows
(List.map (fun v -> <:ctyp< Orpc_js_server.obj -> '$lid:v$ >>) vars)
<:ctyp< Orpc_js_server.obj -> $appd$ >>$
+
+ val $lid:long_of_ id$ :
+ $G.arrows
+ (List.map (fun v -> <:ctyp< '$lid:v$ -> Orpc_js_server.obj >>) vars)
+ (TyArr (_loc, appd, <:ctyp< Orpc_js_server.obj >>))
+ (* <:ctyp< $appd$ -> Orpc_js_server.obj >> broken in 3.12 *)$
>>)
ds$ >>
@@ -73,19 +84,26 @@ let gen_mli name (typedefs, excs, funcs, mode) =
exception $uid:id$ of $tyAnd_of_list (List.map (G.gen_type qual_id) ts)$
>> in
- let gen_func (_, id, args, _) =
+ let gen_func (_, id, args, res) =
let arg =
match List.map typ_of_argtyp_option args with
| [] -> assert false
| [a] -> a
| args -> Tuple (g, args) in
+ let orpc_res =
+ if has_excs
+ then Apply (_loc, ["Orpc"], "orpc_result", [res; Apply (_loc, [], "exn", [])])
+ else res in
let items aid arg =
let t = G.gen_type qual_id arg in
<:sig_item<
val $lid:to_ aid$ : Orpc_js_server.obj -> $t$
+ val $lid:of_ aid$ : $t$ -> Orpc_js_server.obj
>> in
<:sig_item<
+ $items (s_res0 id) res$ ;;
$items (s_arg id) arg$
+ $items (s_res id) orpc_res$
>> in
<:sig_item<
@@ -101,6 +119,7 @@ let gen_mli name (typedefs, excs, funcs, mode) =
then
<:sig_item<
val $lid:long_to_ "exn"$ : Orpc_js_server.obj -> exn
+ val $lid:long_of_ "exn"$ : exn -> Orpc_js_server.obj
>>
else <:sig_item< >>$ ;;
$list:List.map gen_func funcs$ ;;
@@ -143,9 +162,7 @@ let rec gen_to qual_id t x =
let mc (id, ts) i =
match ts with
| [] ->
- <:match_case< Orpc_js_server.Oint $`int:i$ -> $id:qual_id id$ >>
- | [t] ->
- <:match_case< Orpc_js_server.Oblock ($`int:i$, [| x |]) -> $id:qual_id id$ $gen_to t <:expr< x >>$ >>
+ <:match_case< Orpc_js_server.Onumber $`flo:float_of_int i$ -> $id:qual_id id$ >>
| _ ->
let (pps, pes) = G.vars ts in
<:match_case<
@@ -157,7 +174,7 @@ let rec gen_to qual_id t x =
>> in
<:expr<
match $x$ with
- | Orpc_js_server.Oint _ ->
+ | Orpc_js_server.Onumber _ ->
(match $x$ with
$list:
List.mapi
@@ -179,9 +196,7 @@ let rec gen_to qual_id t x =
let mc (id, ts) i =
match ts with
| [] ->
- <:match_case< Orpc_js_server.Oint $`int:i$ -> `$id$ >>
- | [t] ->
- <:match_case< Orpc_js_server.Oblock ($`int:i$, [| x |]) -> `$id$ $gen_to t <:expr< x >>$ >>
+ <:match_case< Orpc_js_server.Onumber $`flo:float_of_int i$ -> `$id$ >>
| _ ->
let (pps, pes) = G.vars ts in
<:match_case<
@@ -193,7 +208,7 @@ let rec gen_to qual_id t x =
>> in
<:expr<
match $x$ with
- | Orpc_js_server.Oint _ ->
+ | Orpc_js_server.Onumber _ ->
(match $x$ with
$list:
List.mapi
@@ -211,15 +226,16 @@ let rec gen_to qual_id t x =
>>
| Array (_loc, t) ->
- <:expr< Array.map (fun x -> $gen_to t <:expr< x >>$) $x$ >>
+ <:expr< Orpc_js_server.to_array (fun x -> $gen_to t <:expr< x >>$) $x$ >>
| List (_loc, t) ->
<:expr< Orpc_js_server.to_list (fun x -> $gen_to t <:expr< x >>$) $x$ >>
| Option (_loc, t) ->
<:expr< Orpc_js_server.to_option (fun x -> $gen_to t <:expr< x >>$) $x$ >>
- | Ref (_loc, t) -> gen_to t <:expr< ! $x$ >>
+ | Ref (_loc, t) ->
+ <:expr< Orpc_js_server.to_ref (fun x -> $gen_to t <:expr< x >>$) $x$ >>
| Apply (_loc, mdl, id, args) ->
<:expr<
@@ -231,6 +247,95 @@ let rec gen_to qual_id t x =
| Arrow _ -> assert false
+let rec gen_of qual_id t v =
+ let gen_of = gen_of qual_id in
+ match t with
+ | Abstract _ -> assert false
+
+ | Var (_loc, id) -> <:expr< $lid:G.of_p id$ $v$ >>
+
+ | Unit _loc -> <:expr< Orpc_js_server.of_unit $v$ >>
+ | Int _loc -> <:expr< Orpc_js_server.of_int $v$ >>
+ | Int32 _loc -> <:expr< Orpc_js_server.of_int32 $v$ >>
+ | Int64 _loc -> <:expr< Orpc_js_server.of_int64 $v$ >>
+ | Float _loc -> <:expr< Orpc_js_server.of_float $v$ >>
+ | Bool _loc -> <:expr< Orpc_js_server.of_bool $v$ >>
+ | Char _loc -> <:expr< Orpc_js_server.of_char $v$ >>
+ | String _loc -> <:expr< Orpc_js_server.of_string $v$ >>
+
+ | Tuple (_loc, parts) ->
+ let (pps, pes) = G.vars parts in
+ <:expr<
+ let ( $tup:paCom_of_list pps$ ) = $v$ in
+ Orpc_js_server.Oblock (0, [| $exSem_of_list (List.map2 gen_of parts pes)$ |]) (* XXX not sure why list: doesn't work here *)
+ >>
+
+ | Record (_loc, fields) ->
+ let (fps, fes) = G.vars fields in
+ let rb f p = <:patt< $id:qual_id f.f_id$ = $p$ >> in
+ <:expr<
+ let { $paSem_of_list (List.map2 rb fields fps)$ } = $v$ in
+ Orpc_js_server.Oblock (0,
+ [| $exSem_of_list (List.map2 (fun f v -> gen_of f.f_typ v) fields fes)$ |])
+ >>
+
+ | Variant (_loc, arms) ->
+ let mc (id, ts) i =
+ match ts with
+ | [] ->
+ <:match_case< $id:qual_id id$ -> Orpc_js_server.of_int $`int:i$ >>
+ | _ ->
+ let (pps, pes) = G.vars ts in
+ <:match_case<
+ $G.papps <:patt< $id:qual_id id$ >> pps$ ->
+ Orpc_js_server.Oblock ($`int:i$, [| $exSem_of_list (List.map2 gen_of ts pes)$ |])
+ >> in
+ <:expr<
+ match $v$ with
+ | $list:List.mapi mc (List.filter (fun (_, ts) -> ts = []) arms)$
+ | $list:List.mapi mc (List.filter (fun (_, ts) -> ts <> []) arms)$
+ >>
+
+ | PolyVar (_loc, _, arms) ->
+ let arms = List.map (function Pv_pv _ -> assert false | Pv_of (id, ts) -> (id, ts)) arms in
+ let mc (id, ts) i =
+ match ts with
+ | [] ->
+ <:match_case< `$id$ -> Orpc_js_server.of_int $`int:i$ >>
+ | _ ->
+ let (pps, pes) = G.vars ts in
+ <:match_case<
+ $G.papps <:patt< `$id$ >> pps$ ->
+ Orpc_js_server.Oblock ($`int:i$, [| $exSem_of_list (List.map2 gen_of ts pes)$ |])
+ >> in
+ <:expr<
+ match $v$ with
+ | $list:List.mapi mc (List.filter (fun (_, ts) -> ts = []) arms)$
+ | $list:List.mapi mc (List.filter (fun (_, ts) -> ts <> []) arms)$
+ >>
+
+ | Array (_loc, t) ->
+ <:expr< Orpc_js_server.of_array (fun v -> $gen_of t <:expr< v >>$) $v$ >>
+
+ | List (_loc, t) ->
+ <:expr< Orpc_js_server.of_list (fun v -> $gen_of t <:expr< v >>$) $v$ >>
+
+ | Option (_loc, t) ->
+ <:expr< Orpc_js_server.of_option (fun v -> $gen_of t <:expr< v >>$) $v$ >>
+
+ | Ref (_loc, t) ->
+ <:expr< Orpc_js_server.of_ref (fun v -> $gen_of t <:expr< v >>$) $v$ >>
+
+ | Apply (_loc, mdl, id, args) ->
+ <:expr<
+ $G.apps
+ (<:expr< $id:G.module_id mdl (long_of_ id)$ >>)
+ (List.map (fun a -> <:expr< fun v -> $gen_of a <:expr< v >>$ >>) args)$
+ $v$
+ >>
+
+ | Arrow _ -> assert false
+
let gen_str_typedef ?(qual_id=G.id) stub ds =
<:str_item<
let rec
@@ -250,6 +355,12 @@ let gen_ml name (typedefs, excs, funcs, mode) =
let has_excs = excs <> [] in
let qual_id = G.qual_id name mode in
+ let gen_of_exc t v =
+ match gen_of qual_id t v with
+ | ExMat (loc, e, cases) ->
+ ExMat (loc, e, McOr(_loc, cases, <:match_case< _ -> raise $v$ >>))
+ | _ -> assert false in
+
let gen_typedef_typs ds =
<:str_item<
type
@@ -271,17 +382,26 @@ let gen_ml name (typedefs, excs, funcs, mode) =
exception $uid:id$ of $tyAnd_of_list (List.map (G.gen_type qual_id) ts)$
>> in
- let gen_func (_, id, args, _) =
+ let gen_func (_, id, args, res) =
let arg =
match List.map typ_of_argtyp_option args with
| [] -> assert false
| [a] -> a
| args -> Tuple (_loc, args) in
+ let orpc_res =
+ if has_excs
+ then Apply (_loc, ["Orpc_onc"], "orpc_result", [res; Apply (_loc, [], "exn", [])])
+ else res in
let items aid arg =
<:str_item<
let $lid:to_ aid$ x = $gen_to qual_id arg <:expr< x >>$
+ let $lid:of_ aid$ v = $gen_of qual_id arg <:expr< v >>$
>> in
- <:str_item< $items (s_arg id) arg$ >> in
+ <:str_item<
+ $items (s_res0 id) res$ ;;
+ $items (s_arg id) arg$ ;;
+ $items (s_res id) orpc_res$ ;;
+ >> in
<:str_item<
$match mode with
@@ -295,7 +415,10 @@ let gen_ml name (typedefs, excs, funcs, mode) =
$if has_excs
then
let t = Variant (_loc, List.map (fun (_, id, ts) -> (id, ts)) excs) in
- <:str_item< let $lid:long_to_ "exn"$ x = $gen_to qual_id t <:expr< x >>$ >>
+ <:str_item<
+ let $lid:long_to_ "exn"$ x = $gen_to qual_id t <:expr< x >>$ ;;
+ let $lid:long_of_ "exn"$ v = $gen_of_exc t <:expr< v >>$ ;;
+ >>
else <:str_item< >>$ ;;
$list:List.map gen_func funcs$ ;;
>>
@@ -61,12 +61,13 @@ let gen_ml name (typedefs, excs, funcs, mode) =
let aux_id id = <:ident< $uid:name ^ "_js_aux"$ . $lid:id$ >> in
let to_arg id = aux_id ("to_" ^ id ^ "'arg") in
+ let of_res id = aux_id ("of_" ^ id ^ "'res") in
let sync_func (_, id, args, _) =
<:expr<
($`str:id$,
fun x0 ->
- Obj.repr
+ $id:of_res id$
$(fun body ->
if has_excs
then <:expr< pack_orpc_result (fun () -> $body$) >>
@@ -91,7 +92,7 @@ let gen_ml name (typedefs, excs, funcs, mode) =
let ( $tup:paCom_of_list ps$ ) = $id:to_arg id$ x0 in
$G.args_apps <:expr< A.$lid:id$ >> args$
>>)$
- (fun r -> let r = Obj.repr (r ()) in rf (fun () -> r)))
+ (fun r -> let r = $id:of_res id$ (r ()) in rf (fun () -> r)))
>> in
let lwt_func (_, id, args, _) =
@@ -107,13 +108,13 @@ let gen_ml name (typedefs, excs, funcs, mode) =
>>$)
(fun v ->
Lwt.return
- (Obj.repr
+ ($id:of_res id$
($if has_excs
then <:expr< Orpc.Orpc_success v >>
else <:expr< v >>$)))
(fun e ->
$if has_excs
- then <:expr< Lwt.return (Obj.repr (map_exns e)) >>
+ then <:expr< Lwt.return ($id:of_res id$ (map_exns e)) >>
else <:expr< Lwt.fail e >>$))
>> in
@@ -27,7 +27,7 @@ let serialize o =
match Javascript.typeof o with
| "string" -> push (Obj.repr "s"); push_ffff o
| "number" -> push_ffff o
- | "boolean" -> push_ffff (Obj.repr (if Obj.obj o then 1 else 0))
+ | "boolean" -> push (Obj.repr (if Obj.obj o then "t" else "f"))
| "object" -> (* XXX check for Array *)
push (Obj.repr "[");
let s = Obj.size o - 1 in
@@ -38,6 +38,8 @@ let serialize o =
loop o;
a#join ""
+let unserialize = Javascript.eval
+
(* this is in dom package but don't want dependency *)
class type xMLHttpRequest =
object
@@ -67,7 +69,7 @@ let sync_call url proc arg =
xhr#setRequestHeader "Content-Type" "text/plain";
xhr#send (serialize (Obj.repr (proc, arg)));
if xhr#_get_status = 200
- then Javascript.eval xhr#_get_responseText
+ then unserialize xhr#_get_responseText
else raise (Failure xhr#_get_statusText)
let add_call url proc arg pass_reply =
@@ -77,7 +79,7 @@ let add_call url proc arg pass_reply =
| 4 ->
let r =
if xhr#_get_status = 200
- then let o = Javascript.eval xhr#_get_responseText in (fun () -> o)
+ then let o = unserialize xhr#_get_responseText in (fun () -> o)
else let s = xhr#_get_statusText in (fun () -> raise (Failure s)) in
pass_reply r
| _ -> ());
Oops, something went wrong.

0 comments on commit 7d3d471

Please sign in to comment.