Permalink
Browse files

removed support for simple mode

  • Loading branch information...
1 parent 9cf7310 commit 701c325199d1bb8f916f28f33a87c52f3a428aa0 Jake Donham committed Jul 20, 2010
View
2 examples/Makefile
@@ -1,6 +1,6 @@
-include ../Makefile.conf
-DIRS=matrixmult modules simple
+DIRS=matrixmult modules
ifeq ($(ENABLE_OCAMLJS),1)
DIRS += clicks
View
9 examples/simple/Makefile
@@ -1,9 +0,0 @@
-all: myocamlbuild.ml
- ocamlbuild client.byte server.byte
-
-clean:
- ocamlbuild -clean
- rm -f myocamlbuild.ml
-
-myocamlbuild.ml:
- ln -s ../../tools/myocamlbuild.ml .
View
6 examples/simple/README
@@ -1,6 +0,0 @@
-1. Build with `make`
-2. Run server with `./server.byte -conf server.cfg`
-3. Run client with `./client.byte`
-
-You can try sync vs. async interfaces by editing the bottom of
-client.ml and the `~setup` in server.ml.
View
2 examples/simple/_tags
@@ -1,2 +0,0 @@
-<*.ml*> : pkg_orpc-onc, pkg_netplex
-<*.byte> : pkg_orpc-onc, pkg_netplex
View
78 examples/simple/client.ml
@@ -1,78 +0,0 @@
-let rec lst_of_list l =
- match l with
- | [] -> Protocol_aux.Nil
- | a::l -> Protocol_aux.Cons (a, lst_of_list l)
-
-module Pp = Protocol_trace.Pp
-
-let main () =
- let c = Protocol_clnt.create_client (Rpc_client.Inet ("localhost", 9007)) Rpc.Tcp in
- let fmt = Format.err_formatter in
-
- Pp.orpc_trace_pp_add1'call fmt 6;
- Pp.orpc_trace_pp_add1'reply fmt
- (Protocol_clnt.add1 c 6);
-
- Pp.orpc_trace_pp_addN'call fmt ~n:7 6;
- Pp.orpc_trace_pp_addN'reply fmt
- (Protocol_clnt.addN c ~n:7 6);
-
- Pp.orpc_trace_pp_add1_list'call fmt [5;6;7];
- Pp.orpc_trace_pp_add1_list'reply fmt
- (Protocol_clnt.add1_list c [5;6;7]);
-
- Pp.orpc_trace_pp_add1_lst'call fmt (lst_of_list [7;8;9]);
- Pp.orpc_trace_pp_add1_lst'reply fmt
- (Protocol_clnt.add1_lst c (lst_of_list [7;8;9]));
-
- Pp.orpc_trace_pp_add1_pair'call fmt (17, 22);
- Pp.orpc_trace_pp_add1_pair'reply fmt
- (Protocol_clnt.add1_pair c (17, 22));
-
- Pp.orpc_trace_pp_maybe_raise'call fmt true;
- try
- Pp.orpc_trace_pp_maybe_raise'reply fmt
- (Protocol_clnt.maybe_raise c true)
- with e -> Pp.orpc_trace_pp_exn'reply fmt e;
-
- Rpc_client.shut_down c
-
-let main_async () =
- let esys = Unixqueue.create_unix_event_system() in
- let c = Protocol_clnt.create_client ~esys (Rpc_client.Inet ("localhost", 9007)) Rpc.Tcp in
- let fmt = Format.err_formatter in
-
- Pp.orpc_trace_pp_add1'call fmt 6;
- Protocol_clnt.add1'async c 6
- (fun r -> Pp.orpc_trace_pp_add1'reply fmt (r ()));
-
- Pp.orpc_trace_pp_addN'call fmt ~n:7 6;
- Protocol_clnt.addN'async c ~n:7 6
- (fun r -> Pp.orpc_trace_pp_addN'reply fmt (r ()));
-
- Pp.orpc_trace_pp_add1_list'call fmt [5;6;7];
- Protocol_clnt.add1_list'async c [5;6;7]
- (fun r -> Pp.orpc_trace_pp_add1_list'reply fmt (r ()));
-
- Pp.orpc_trace_pp_add1_lst'call fmt (lst_of_list [7;8;9]);
- Protocol_clnt.add1_lst'async c (lst_of_list [7;8;9])
- (fun r -> Pp.orpc_trace_pp_add1_lst'reply fmt (r ()));
-
- Pp.orpc_trace_pp_add1_pair'call fmt (17, 22);
- Protocol_clnt.add1_pair'async c (17, 22)
- (fun r -> Pp.orpc_trace_pp_add1_pair'reply fmt (r ()));
-
- Pp.orpc_trace_pp_maybe_raise'call fmt true;
- Protocol_clnt.maybe_raise'async c true
- (fun r ->
- try Pp.orpc_trace_pp_maybe_raise'reply fmt (r ())
- with e -> Pp.orpc_trace_pp_exn'reply fmt e);
-
- Unixqueue.run esys;
- Rpc_client.shut_down c
-
-;;
-
-main ()
-(* main_async () *)
-
View
27 examples/simple/protocol.mli
@@ -1,27 +0,0 @@
-val add1 : int -> int
-
-(* built-in type constructors *)
-val add1_list : int list -> int list
-
-(* tuples *)
-val add1_pair : (int * int) -> (int * int)
-
-(* records *)
-type r = { fst: int; snd: int option; trd: int array; }
-
-val add1_r : r -> r
-
-(* you can define polymorphic datatypes... *)
-type 'a lst = Nil | Cons of 'a * 'a lst
-
-(* but you must pass them at a specific type *)
-val add1_lst : int lst -> int lst
-
-(* labelled and optional arguments *)
-val addN : ?n:int -> int -> int
-
-(* exceptions *)
-exception Foo
-exception Bar of int
-
-val maybe_raise : bool -> unit
View
17 examples/simple/server.cfg
@@ -1,17 +0,0 @@
-netplex {
-
- service {
- name = "add1";
- protocol {
- name = "rpc/add1";
- address { type = "internet"; bind = "127.0.0.1:9007"; };
- };
- processor {
- type = "add1";
- };
- workload_manager {
- type = "constant";
- threads = 1;
- };
- };
-}
View
98 examples/simple/server.ml
@@ -1,98 +0,0 @@
-let rec lst_map f l =
- match l with
- | Protocol_aux.Nil -> Protocol_aux.Nil
- | Protocol_aux.Cons (a,l) -> Protocol_aux.Cons (f a, lst_map f l)
-
-module Sync =
-struct
- let proc_add1 i = i + 1
-
- let proc_add1_list l = List.map (fun i -> i + 1) l
-
- let proc_add1_pair (a, b) = (a + 1, b + 1)
-
- let proc_add1_r { Protocol_aux.fst = f; snd = s; trd = t } =
- {
- Protocol_aux.fst = f + 1;
- snd = (match s with None -> None | Some s -> Some (s + 1));
- trd = Array.map (fun e -> e + 1) t;
- }
-
- let proc_add1_lst l = lst_map (fun i -> i + 1) l
-
- let proc_addN ?(n = 1) i = i + n
-
- let proc_maybe_raise flag =
- if flag
- then raise (Protocol_aux.Bar 17)
-
- let setup srv =
- Protocol_srv.bind
- ~proc_add1 ~proc_add1_list ~proc_add1_pair
- ~proc_add1_r ~proc_add1_lst ~proc_addN
- ~proc_maybe_raise
- srv
-end
-
-module Async =
-struct
- let proc_add1 _ i r = r (i + 1)
-
- let proc_add1_list _ l r = r (List.map (fun i -> i + 1) l)
-
- let proc_add1_pair _ (a, b) r = r (a + 1, b + 1)
-
- let proc_add1_r _ { Protocol_aux.fst = f; snd = s; trd = t } r =
- r {
- Protocol_aux.fst = f + 1;
- snd = (match s with None -> None | Some s -> Some (s + 1));
- trd = Array.map (fun e -> e + 1) t;
- }
-
- let proc_add1_lst _ l r = r (lst_map (fun i -> i + 1) l)
-
- let proc_addN _ ?(n = 1) i r = r (i + n)
-
- let proc_maybe_raise _ flag r =
- if flag
- then raise (Protocol_aux.Bar 17)
- else r ()
-
- let setup srv =
- Protocol_srv.bind_async
- ~proc_add1 ~proc_add1_list ~proc_add1_pair
- ~proc_add1_r ~proc_add1_lst ~proc_addN
- ~proc_maybe_raise
- srv
-end
-
-let start() =
- let (opt_list, cmdline_cfg) = Netplex_main.args() in
-
- Arg.parse
- opt_list
- (fun s -> raise (Arg.Bad ("Don't know what to do with: " ^ s)))
- "usage: netplex [options]";
-
- let factories =
- [ Rpc_netplex.rpc_factory
- ~configure:(fun _ _ -> ())
- ~name:"add1"
- ~setup:(fun srv () ->
- Sync.setup srv
- (* Async.setup srv *))
- ();
- ]
- in
-
- Netplex_main.startup
- (Netplex_mp.mp())
- Netplex_log.logger_factories (* allow all built-in logging styles *)
- Netplex_workload.workload_manager_factories (* ... all ways of workload management *)
- factories
- cmdline_cfg
-;;
-
-Sys.set_signal Sys.sigpipe Sys.Signal_ignore;
-start()
-;;
View
22 src/generator/check.ml
@@ -324,29 +324,21 @@ let expand_polyvars_func typedefs (_loc, id, args, ret) =
args,
ep ret)
-let check_interface (typedefs, excs, funcs, mts) =
- let funcs =
- match funcs with
- | [] -> get_module_type_funcs mts
- | _ -> funcs in
+let check_interface (typedefs, excs, mts) =
+ let funcs = get_module_type_funcs mts in
(* XXX this doesn't check that typedefs precede their uses in excs/funcs *)
let ids = check_typedefs [] typedefs in
check_excs ids excs;
check_funcs ids [] funcs;
- let mode =
- match mts with
- | [] -> Simple
- | _ ->
- let mts_noabs = List.filter (function { mt_kind = Ik_abstract } -> false | _ -> true) mts in
- let has_abstract = mts_noabs <> mts in
- List.iter (check_module_type_funcs has_abstract funcs) mts_noabs;
- let kinds = List.map (fun { mt_kind = kind } -> kind) mts_noabs in
- Modules kinds in
+ let mts_noabs = List.filter (function { mt_kind = Ik_abstract } -> false | _ -> true) mts in
+ let has_abstract = mts_noabs <> mts in
+ List.iter (check_module_type_funcs has_abstract funcs) mts_noabs;
+ let kinds = List.map (fun { mt_kind = kind } -> kind) mts_noabs in
let typedefs = List.map (List.map (expand_polyvars_typedef typedefs)) typedefs in
let excs = List.map (expand_polyvars_exc typedefs) excs in
let funcs = List.map (expand_polyvars_func typedefs) funcs in
- (typedefs, excs, funcs, mode)
+ (typedefs, excs, funcs, kinds)
View
62 src/generator/gen_aux.ml
@@ -68,29 +68,10 @@ let gen_sig_typedef ?(qual_id=G.id) ds =
ds$
>>
-let gen_mli name (typedefs, excs, funcs, mode) =
+let gen_mli name (typedefs, excs, funcs, kinds) =
let has_excs = excs <> [] in
- let qual_id = G.qual_id name mode in
-
- let gen_typedef_typs ds =
- <:sig_item<
- type $list:
- List.map
- (fun { td_vars = vars; td_id = id; td_typ = t; td_eq = eq } ->
- let t = G.gen_type qual_id t in
- let t =
- match eq with
- | Some eq -> TyMan (_loc, TyId (_loc, eq), t)
- | None -> t in
- TyDcl (_loc, id, G.tvars vars, t, []))
- ds$
- >> in
-
- let gen_exc (_, id, ts) =
- <:sig_item<
- exception $uid:id$ of $tyAnd_of_list (List.map (G.gen_type qual_id) ts)$
- >> in
+ let qual_id = G.qual_id name in
let gen_func (_, id, args, res) =
let arg =
@@ -115,13 +96,6 @@ let gen_mli name (typedefs, excs, funcs, mode) =
>> in
<:sig_item<
- $match mode with
- | Simple ->
- <:sig_item<
- $list:List.map gen_typedef_typs typedefs$ ;;
- $list:List.map gen_exc excs$ ;;
- >>
- | _ -> <:sig_item< >>$ ;;
$list:List.map (gen_sig_typedef ~qual_id) typedefs$ ;;
$if has_excs
then
@@ -501,37 +475,16 @@ let gen_str_typedef ?(qual_id=G.id) stub ds =
List.map (fun b -> <:str_item< let $b$ >>) (loop ds)$ ;;
>>
-let gen_ml name (typedefs, excs, funcs, mode) =
+let gen_ml name (typedefs, excs, funcs, kinds) =
let has_excs = excs <> [] in
- let qual_id = G.qual_id name mode in
+ let qual_id = G.qual_id name 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
- $list:
- List.map
- (fun { td_vars = vars; td_id = id; td_typ = t; td_eq = eq } ->
- let vars = List.map (fun v -> <:ctyp< '$lid:v$ >>) vars in
- let t = G.gen_type qual_id t in
- let t =
- match eq with
- | Some eq -> TyMan (_loc, TyId (_loc, eq), t)
- | None -> t in
- TyDcl (_loc, id, vars, t, []))
- ds$
- >> in
-
- let gen_exc (_, id, ts) =
- <:str_item<
- exception $uid:id$ of $tyAnd_of_list (List.map (G.gen_type qual_id) ts)$
- >> in
-
let gen_func (_, id, args, res) =
let arg =
match List.map typ_of_argtyp_option args with
@@ -554,13 +507,6 @@ let gen_ml name (typedefs, excs, funcs, mode) =
>> in
<:str_item<
- $match mode with
- | Simple ->
- <:str_item<
- $list:List.map gen_typedef_typs typedefs$ ;;
- $list:List.map gen_exc excs$ ;;
- >>
- | _ -> <:str_item< >>$ ;;
$list:List.map (gen_str_typedef ~qual_id false) typedefs$ ;;
$if has_excs
then
View
116 src/generator/gen_clnt.ml
@@ -28,21 +28,18 @@ module G = Gen_common
let _loc = Camlp4.PreCast.Loc.ghost
-let gen_mli name (typedefs, excs, funcs, mode) =
+let gen_mli name (typedefs, excs, funcs, kinds) =
- let qual_id = G.qual_id_aux name mode in
+ let qual_id = G.qual_id_aux name in
let modules =
- match mode with
- | Simple -> []
- | Modules kinds ->
- List.map
- (fun kind ->
- let mt = G.string_of_kind kind in
- <:sig_item<
- module $uid:mt$(C : sig val with_client : (Rpc_client.t -> 'a) -> 'a end) : $uid:name$.$uid:mt$
- >>)
- kinds in
+ List.map
+ (fun kind ->
+ let mt = G.string_of_kind kind in
+ <:sig_item<
+ module $uid:mt$(C : sig val with_client : (Rpc_client.t -> 'a) -> 'a end) : $uid:name$.$uid:mt$
+ >>)
+ kinds in
<:sig_item<
val create_client :
@@ -90,7 +87,7 @@ let gen_mli name (typedefs, excs, funcs, mode) =
$list:modules$
>>
-let gen_ml name (typedefs, excs, funcs, mode) =
+let gen_ml name (typedefs, excs, funcs, kinds) =
let has_excs = excs <> [] in
let of_arg = G.of_arg name in
@@ -138,54 +135,51 @@ let gen_ml name (typedefs, excs, funcs, mode) =
>> in
let modules =
- match mode with
- | Simple -> []
- | Modules kinds ->
- List.map
- (fun kind ->
- let func (_, id, args, res) =
- <:str_item<
- let $lid:id$ =
- $G.args_funs args
- (match kind with
- | Ik_abstract -> assert false
-
- | Sync ->
- <:expr<
- C.with_client
- (fun c -> $G.args_apps <:expr< $lid:id$ c >> args$)
- >>
- | Async ->
- <:expr<
- fun pass_reply ->
- C.with_client
- (fun c ->
- $G.args_apps <:expr< $lid:id ^ "'async"$ c >> args$
- pass_reply)
- >>
- | Lwt ->
- <:expr<
- C.with_client
- (fun c ->
- let t, u = Lwt.wait () in
- $G.args_apps <:expr< $lid:id ^ "'async"$ c >> args$
- (fun r ->
- match Orpc.pack_orpc_result r with
- | Orpc.Orpc_success v -> Lwt.wakeup u v
- | Orpc.Orpc_failure e -> Lwt.wakeup_exn u e);
- t)
- >>)$
- >> in
-
- <:str_item<
- module $uid:G.string_of_kind kind$(C : sig val with_client : (Rpc_client.t -> 'a) -> 'a end) =
- struct
- $G._r_of_kind kind$;;
- $list:List.map func funcs$
- end
- >>)
-
- kinds in
+ List.map
+ (fun kind ->
+ let func (_, id, args, res) =
+ <:str_item<
+ let $lid:id$ =
+ $G.args_funs args
+ (match kind with
+ | Ik_abstract -> assert false
+
+ | Sync ->
+ <:expr<
+ C.with_client
+ (fun c -> $G.args_apps <:expr< $lid:id$ c >> args$)
+ >>
+ | Async ->
+ <:expr<
+ fun pass_reply ->
+ C.with_client
+ (fun c ->
+ $G.args_apps <:expr< $lid:id ^ "'async"$ c >> args$
+ pass_reply)
+ >>
+ | Lwt ->
+ <:expr<
+ C.with_client
+ (fun c ->
+ let t, u = Lwt.wait () in
+ $G.args_apps <:expr< $lid:id ^ "'async"$ c >> args$
+ (fun r ->
+ match Orpc.pack_orpc_result r with
+ | Orpc.Orpc_success v -> Lwt.wakeup u v
+ | Orpc.Orpc_failure e -> Lwt.wakeup_exn u e);
+ t)
+ >>)$
+ >> in
+
+ <:str_item<
+ module $uid:G.string_of_kind kind$(C : sig val with_client : (Rpc_client.t -> 'a) -> 'a end) =
+ struct
+ $G._r_of_kind kind$;;
+ $list:List.map func funcs$
+ end
+ >>)
+
+ kinds in
<:str_item<
let create_client
View
37 src/generator/gen_common.ml
@@ -112,33 +112,18 @@ let module_id uids lid =
Ast.idAcc_of_list
(List.map (fun uid -> <:ident< $uid:uid$ >>) uids @ [ <:ident< $lid:lid$ >> ])
-let qual_id name mode id =
+let qual_id name id =
+ match id with
+ | "exn" -> <:ident< exn >>
+ | _ ->
+ if is_uppercase id.[0]
+ then <:ident< $uid:name$.$uid:id$ >>
+ else <:ident< $uid:name$.$lid:id$ >>
+
+let qual_id_aux name id =
if is_uppercase id.[0]
- then
- match mode with
- | Simple -> <:ident< $uid:id$ >>
- | Modules _ ->
- match id with
- | "exn" -> <:ident< exn >>
- | _ -> <:ident< $uid:name$.$uid:id$ >>
- else
- match mode with
- | Simple -> <:ident< $lid:id$ >>
- | Modules _ ->
- match id with
- | "exn" -> <:ident< exn >>
- | _ -> <:ident< $uid:name$.$lid:id$ >>
-
-let qual_id_aux name mode id =
- if is_uppercase id.[0]
- then
- match mode with
- | Simple -> <:ident< $uid:name ^ "_aux"$.$uid:id$ >>
- | Modules _ -> <:ident< $uid:name$.$uid:id$ >>
- else
- match mode with
- | Simple -> <:ident< $uid:name ^ "_aux"$.$lid:id$ >>
- | Modules _ -> <:ident< $uid:name$.$lid:id$ >>
+ then <:ident< $uid:name$.$uid:id$ >>
+ else <:ident< $uid:name$.$lid:id$ >>
let gen_type qual_id t =
View
4 src/generator/gen_common.mli
@@ -43,8 +43,8 @@ val papps : Ast.patt -> Ast.patt list -> Ast.patt
val conses : Ast.expr list -> Ast.expr
val id : string -> Ast.ident
val module_id : string list -> string -> Ast.ident
-val qual_id : string -> Types.mode -> string -> Ast.ident
-val qual_id_aux : string -> Types.mode -> string -> Ast.ident
+val qual_id : string -> string -> Ast.ident
+val qual_id_aux : string -> string -> Ast.ident
val gen_type : (Types.ident -> Ast.ident) -> Types.typ -> Ast.ctyp
val args_funs : Types.argtyp list -> Ast.expr -> Ast.expr
val args_apps : Ast.expr -> Types.argtyp list -> Ast.expr
View
63 src/generator/gen_js_aux.ml
@@ -69,30 +69,10 @@ let gen_sig_typedef ?(qual_id=G.id) ds =
>>)
ds$ >>
-let gen_mli name (typedefs, excs, funcs, mode) =
+let gen_mli name (typedefs, excs, funcs, kinds) =
let has_excs = excs <> [] in
- let qual_id = G.qual_id name mode in
-
- let gen_typedef_typs ds =
- <:sig_item<
- type
- $list:
- List.map
- (fun { td_vars = vars; td_id = id; td_typ = t; td_eq = eq } ->
- let t = G.gen_type qual_id t in
- let t =
- match eq with
- | Some eq -> TyMan (_loc, TyId (_loc, eq), t)
- | None -> t in
- TyDcl (_loc, id, G.tvars vars, t, []))
- ds$
- >> in
-
- let gen_exc (_, id, ts) =
- <:sig_item<
- exception $uid:id$ of $tyAnd_of_list (List.map (G.gen_type qual_id) ts)$
- >> in
+ let qual_id = G.qual_id name in
let gen_func (_, id, args, res) =
let arg =
@@ -116,13 +96,6 @@ let gen_mli name (typedefs, excs, funcs, mode) =
>> in
<:sig_item<
- $match mode with
- | Simple ->
- <:sig_item<
- $list:List.map gen_typedef_typs typedefs$ ;;
- $list:List.map gen_exc excs$ ;;
- >>
- | _ -> <:sig_item< >>$ ;;
$list:List.map (gen_sig_typedef ~qual_id) typedefs$ ;;
$if has_excs
then
@@ -332,37 +305,16 @@ let gen_str_typedef ?(qual_id=G.id) stub ds =
ds$
>>
-let gen_ml name (typedefs, excs, funcs, mode) =
+let gen_ml name (typedefs, excs, funcs, kinds) =
let has_excs = excs <> [] in
- let qual_id = G.qual_id name mode in
+ let qual_id = G.qual_id name 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
- $list:
- List.map
- (fun { td_vars = vars; td_id = id; td_typ = t; td_eq = eq } ->
- let vars = List.map (fun v -> <:ctyp< '$lid:v$ >>) vars in
- let t = G.gen_type qual_id t in
- let t =
- match eq with
- | Some eq -> TyMan (_loc, TyId (_loc, eq), t)
- | None -> t in
- TyDcl (_loc, id, vars, t, []))
- ds$
- >> in
-
- let gen_exc (_, id, ts) =
- <:str_item<
- exception $uid:id$ of $tyAnd_of_list (List.map (G.gen_type qual_id) ts)$
- >> in
-
let gen_func (_, id, args, res) =
let arg =
match List.map typ_of_argtyp_option args with
@@ -384,13 +336,6 @@ let gen_ml name (typedefs, excs, funcs, mode) =
>> in
<:str_item<
- $match mode with
- | Simple ->
- <:str_item<
- $list:List.map gen_typedef_typs typedefs$ ;;
- $list:List.map gen_exc excs$ ;;
- >>
- | _ -> <:str_item< >>$ ;;
$list:List.map (gen_str_typedef ~qual_id false) typedefs$ ;;
$if has_excs
then
View
118 src/generator/gen_js_clnt.ml
@@ -28,21 +28,18 @@ module G = Gen_common
let _loc = Camlp4.PreCast.Loc.ghost
-let gen_mli name (typedefs, excs, funcs, mode) =
+let gen_mli name (typedefs, excs, funcs, kinds) =
- let qual_id = G.qual_id_aux name mode in
+ let qual_id = G.qual_id_aux name in
let modules =
- match mode with
- | Simple -> []
- | Modules kinds ->
- List.map
- (fun kind ->
- let mt = G.string_of_kind kind in
- <:sig_item<
- module $uid:mt$(C : sig val with_client : (Orpc_js_client.t -> 'a) -> 'a end) : $uid:name$.$uid:mt$
- >>)
- kinds in
+ List.map
+ (fun kind ->
+ let mt = G.string_of_kind kind in
+ <:sig_item<
+ module $uid:mt$(C : sig val with_client : (Orpc_js_client.t -> 'a) -> 'a end) : $uid:name$.$uid:mt$
+ >>)
+ kinds in
<:sig_item<
$list:
@@ -67,9 +64,9 @@ let gen_mli name (typedefs, excs, funcs, mode) =
$list:modules$
>>
-let gen_ml name (typedefs, excs, funcs, mode) =
+let gen_ml name (typedefs, excs, funcs, kinds) =
- let qual_id = G.qual_id_aux name mode in
+ let qual_id = G.qual_id_aux name in
let has_excs = excs <> [] in
@@ -112,54 +109,51 @@ let gen_ml name (typedefs, excs, funcs, mode) =
>> in
let modules =
- match mode with
- | Simple -> []
- | Modules kinds ->
- List.map
- (fun kind ->
- let func (_, id, args, res) =
- <:str_item<
- let $lid:id$ =
- $G.args_funs args
- (match kind with
- | Ik_abstract -> assert false
-
- | Sync ->
- <:expr<
- C.with_client
- (fun c -> $G.args_apps <:expr< $lid:id$ c >> args$)
- >>
- | Async ->
- <:expr<
- fun pass_reply ->
- C.with_client
- (fun c ->
- $G.args_apps <:expr< $lid:id ^ "'async"$ c >> args$
- pass_reply)
- >>
- | Lwt ->
- <:expr<
- C.with_client
- (fun c ->
- let t, u = Lwt.wait () in
- $G.args_apps <:expr< $lid:id ^ "'async"$ c >> args$
- (fun r ->
- match Orpc.pack_orpc_result r with
- | Orpc.Orpc_success v -> Lwt.wakeup u v
- | Orpc.Orpc_failure e -> Lwt.wakeup_exn u e);
- t)
- >>)$
- >> in
-
- <:str_item<
- module $uid:G.string_of_kind kind$(C : sig val with_client : (Orpc_js_client.t -> 'a) -> 'a end) =
- struct
- $G._r_of_kind kind$;;
- $list:List.map func funcs$
- end
- >>)
-
- kinds in
+ List.map
+ (fun kind ->
+ let func (_, id, args, res) =
+ <:str_item<
+ let $lid:id$ =
+ $G.args_funs args
+ (match kind with
+ | Ik_abstract -> assert false
+
+ | Sync ->
+ <:expr<
+ C.with_client
+ (fun c -> $G.args_apps <:expr< $lid:id$ c >> args$)
+ >>
+ | Async ->
+ <:expr<
+ fun pass_reply ->
+ C.with_client
+ (fun c ->
+ $G.args_apps <:expr< $lid:id ^ "'async"$ c >> args$
+ pass_reply)
+ >>
+ | Lwt ->
+ <:expr<
+ C.with_client
+ (fun c ->
+ let t, u = Lwt.wait () in
+ $G.args_apps <:expr< $lid:id ^ "'async"$ c >> args$
+ (fun r ->
+ match Orpc.pack_orpc_result r with
+ | Orpc.Orpc_success v -> Lwt.wakeup u v
+ | Orpc.Orpc_failure e -> Lwt.wakeup_exn u e);
+ t)
+ >>)$
+ >> in
+
+ <:str_item<
+ module $uid:G.string_of_kind kind$(C : sig val with_client : (Orpc_js_client.t -> 'a) -> 'a end) =
+ struct
+ $G._r_of_kind kind$;;
+ $list:List.map func funcs$
+ end
+ >>)
+
+ kinds in
(* exceptions are pointer-compared, so we need to map back to the right ones *)
let unpack_orpc_result () =
View
74 src/generator/gen_js_srv.ml
@@ -28,36 +28,33 @@ module G = Gen_common
let _loc = Camlp4.PreCast.Loc.ghost
-let gen_mli name (typedefs, excs, funcs, mode) =
+let gen_mli name (typedefs, excs, funcs, kinds) =
let modules =
- match mode with
- | Simple -> failwith "simple mode not supported for js_srv"
- | Modules kinds ->
- List.map
- (fun kind ->
- let mt, monad =
- match kind with
- | Ik_abstract -> assert false
- | Sync -> "Sync", <:ident< Orpc_js_server.Sync >>
- | Async -> "Async", <:ident< Orpc_js_server.Async >>
- | Lwt -> "Lwt", <:ident< Lwt >> in
- <:sig_item<
- module $uid:mt$ : functor (A : $uid:name$.$uid:mt$) ->
- sig
- val handler : string -> string $id:monad$.t
- end
- >>)
- kinds in
+ List.map
+ (fun kind ->
+ let mt, monad =
+ match kind with
+ | Ik_abstract -> assert false
+ | Sync -> "Sync", <:ident< Orpc_js_server.Sync >>
+ | Async -> "Async", <:ident< Orpc_js_server.Async >>
+ | Lwt -> "Lwt", <:ident< Lwt >> in
+ <:sig_item<
+ module $uid:mt$ : functor (A : $uid:name$.$uid:mt$) ->
+ sig
+ val handler : string -> string $id:monad$.t
+ end
+ >>)
+ kinds in
<:sig_item< $list:modules$ >>
-let gen_ml name (typedefs, excs, funcs, mode) =
+let gen_ml name (typedefs, excs, funcs, kinds) =
let has_excs = excs <> [] in
- let qual_id = G.qual_id_aux name mode in
+ let qual_id = G.qual_id_aux name in
let aux_id id = <:ident< $uid:name ^ "_js_aux"$ . $lid:id$ >> in
let to_arg id = aux_id ("to_" ^ id ^ "'arg") in
@@ -119,25 +116,22 @@ let gen_ml name (typedefs, excs, funcs, mode) =
>> in
let modules =
- match mode with
- | Simple -> failwith "simple mode not supported for js_srv"
- | Modules kinds ->
- List.map
- (fun kind ->
- let mt, monad, func =
- match kind with
- | Ik_abstract -> assert false
- | Sync -> "Sync", <:ident< Orpc_js_server.Sync >>, sync_func
- | Async -> "Async", <:ident< Orpc_js_server.Async >>, async_func
- | Lwt -> "Lwt", <:ident< Lwt >>, lwt_func in
- <:str_item<
- module $uid:mt$ (A : $uid:name$.$uid:mt$) =
- struct
- module H = Orpc_js_server.Handler($id:monad$)
- let handler = H.handler $G.conses (List.map func funcs)$
- end
- >>)
- kinds in
+ List.map
+ (fun kind ->
+ let mt, monad, func =
+ match kind with
+ | Ik_abstract -> assert false
+ | Sync -> "Sync", <:ident< Orpc_js_server.Sync >>, sync_func
+ | Async -> "Async", <:ident< Orpc_js_server.Async >>, async_func
+ | Lwt -> "Lwt", <:ident< Lwt >>, lwt_func in
+ <:str_item<
+ module $uid:mt$ (A : $uid:name$.$uid:mt$) =
+ struct
+ module H = Orpc_js_server.Handler($id:monad$)
+ let handler = H.handler $G.conses (List.map func funcs)$
+ end
+ >>)
+ kinds in
let pack_orpc_result () =
let mc (_,id,ts) =
View
130 src/generator/gen_srv.ml
@@ -28,27 +28,24 @@ module G = Gen_common
let _loc = Camlp4.PreCast.Loc.ghost
-let gen_mli name (typedefs, excs, funcs, mode) =
+let gen_mli name (typedefs, excs, funcs, kinds) =
- let qual_id = G.qual_id_aux name mode in
+ let qual_id = G.qual_id_aux name in
let modules =
- match mode with
- | Simple -> []
- | Modules kinds ->
- List.map
- (fun kind ->
- let mt = G.string_of_kind kind in
- <:sig_item<
- module $uid:mt$ : functor (A : $uid:name$.$uid:mt$) ->
- sig
- val bind :
- ?program_number:Rtypes.uint4 ->
- ?version_number:Rtypes.uint4 ->
- Rpc_server.t -> unit
- end
- >>)
- kinds in
+ List.map
+ (fun kind ->
+ let mt = G.string_of_kind kind in
+ <:sig_item<
+ module $uid:mt$ : functor (A : $uid:name$.$uid:mt$) ->
+ sig
+ val bind :
+ ?program_number:Rtypes.uint4 ->
+ ?version_number:Rtypes.uint4 ->
+ Rpc_server.t -> unit
+ end
+ >>)
+ kinds in
<:sig_item<
val bind :
@@ -83,7 +80,7 @@ let gen_mli name (typedefs, excs, funcs, mode) =
-let gen_ml name (typedefs, excs, funcs, mode) =
+let gen_ml name (typedefs, excs, funcs, kinds) =
let has_excs = excs <> [] in
let to_arg = G.to_arg name in
@@ -161,56 +158,53 @@ let gen_ml name (typedefs, excs, funcs, mode) =
>> in
let modules =
- match mode with
- | Simple -> []
- | Modules kinds ->
- List.map
- (fun kind ->
- let mt = G.string_of_kind kind in
- <:str_item<
- module $uid:mt$ (A : $uid:name$.$uid:mt$) =
- struct
- let bind
- ?program_number
- ?version_number
- srv =
- $match kind with
- | Ik_abstract -> assert false
-
- | Sync ->
- List.fold_left
- (fun e (_, id, args, _) ->
- let body = <:expr< A.$lid:id$ >> in
- ExApp(_loc, e, ExLab (_loc, "proc_" ^ id, body)))
- <:expr< bind ?program_number ?version_number >>
- funcs
- | Async ->
- List.fold_left
- (fun e (_, id, args, _) ->
- let body =
- <:expr<
- fun s ->
- $G.args_funs args
- <:expr<
- fun pass_reply ->
- Orpc_onc.session := Some s;
- $G.args_apps <:expr< A.$lid:id$ >> args$
- (fun r -> pass_reply (r ()))
- >>$
- >> in
- ExApp(_loc, e, ExLab (_loc, "proc_" ^ id, body)))
- <:expr< bind_async ?program_number ?version_number >>
- funcs
- | Lwt ->
+ List.map
+ (fun kind ->
+ let mt = G.string_of_kind kind in
+ <:str_item<
+ module $uid:mt$ (A : $uid:name$.$uid:mt$) =
+ struct
+ let bind
+ ?program_number
+ ?version_number
+ srv =
+ $match kind with
+ | Ik_abstract -> assert false
+
+ | Sync ->
+ List.fold_left
+ (fun e (_, id, args, _) ->
+ let body = <:expr< A.$lid:id$ >> in
+ ExApp(_loc, e, ExLab (_loc, "proc_" ^ id, body)))
+ <:expr< bind ?program_number ?version_number >>
+ funcs
+ | Async ->
+ List.fold_left
+ (fun e (_, id, args, _) ->
+ let body =
<:expr<
- Rpc_server.bind
- ?program_number ?version_number $id:G.program name$
- $G.conses (List.map lwt_func funcs)$
- >>$
- srv
- end
- >>)
- kinds in
+ fun s ->
+ $G.args_funs args
+ <:expr<
+ fun pass_reply ->
+ Orpc_onc.session := Some s;
+ $G.args_apps <:expr< A.$lid:id$ >> args$
+ (fun r -> pass_reply (r ()))
+ >>$
+ >> in
+ ExApp(_loc, e, ExLab (_loc, "proc_" ^ id, body)))
+ <:expr< bind_async ?program_number ?version_number >>
+ funcs
+ | Lwt ->
+ <:expr<
+ Rpc_server.bind
+ ?program_number ?version_number $id:G.program name$
+ $G.conses (List.map lwt_func funcs)$
+ >>$
+ srv
+ end
+ >>)
+ kinds in
<:str_item<
let bind
View
38 src/generator/gen_trace.ml
@@ -47,9 +47,9 @@ let gen_sig_typedef ?(qual_id=G.id) ds =
ds in
sgSem_of_list is
-let gen_module_type name (typedefs, _, funcs, mode) =
+let gen_module_type name (typedefs, _, funcs, kinds) =
- let qual_id = G.qual_id_aux name mode in
+ let qual_id = G.qual_id_aux name in
let gen_func (_, id, args, res) =
<:sig_item<
@@ -64,25 +64,22 @@ let gen_module_type name (typedefs, _, funcs, mode) =
val $lid:pp_ "exn'reply"$ : Format.formatter -> exn -> unit;;
>>
-let gen_mli name (typedefs, excs, funcs, mode) =
+let gen_mli name (typedefs, excs, funcs, kinds) =
let modules =
- match mode with
- | Simple -> []
- | Modules kinds ->
- List.map
- (fun kind ->
- let mt = G.string_of_kind kind in
- <:sig_item<
- module $uid:mt ^ "_pp"$ (P : Pp) (T : Orpc_pp.Trace) (A : $uid:name$.$uid:mt$) : $uid:name$.$uid:mt$
- module $uid:mt$ (T : Orpc_pp.Trace) (A : $uid:name$.$uid:mt$) : $uid:name$.$uid:mt$
- >>)
- kinds in
+ List.map
+ (fun kind ->
+ let mt = G.string_of_kind kind in
+ <:sig_item<
+ module $uid:mt ^ "_pp"$ (P : Pp) (T : Orpc_pp.Trace) (A : $uid:name$.$uid:mt$) : $uid:name$.$uid:mt$
+ module $uid:mt$ (T : Orpc_pp.Trace) (A : $uid:name$.$uid:mt$) : $uid:name$.$uid:mt$
+ >>)
+ kinds in
<:sig_item<
module type Pp =
sig
- $gen_module_type name (typedefs, excs, funcs, mode)$
+ $gen_module_type name (typedefs, excs, funcs, kinds)$
end
module Pp_pp (P : Pp) : Pp ;;
@@ -247,9 +244,9 @@ let gen_str_typedef ?(qual_id=G.id) ?(rec_mod=true) stub ds =
ds in
<:str_item< let rec $list:es$ >>
-let gen_ml name (typedefs, excs, funcs, mode) =
+let gen_ml name (typedefs, excs, funcs, kinds) =
- let qual_id = G.qual_id_aux name mode in
+ let qual_id = G.qual_id_aux name in
let gen_pp_exc t =
match gen_format qual_id true t with
@@ -353,15 +350,12 @@ let gen_ml name (typedefs, excs, funcs, mode) =
module $uid:mt$ = $uid:mt ^ "_pp"$ (Pp)
>> in
- let modules =
- match mode with
- | Simple -> []
- | Modules kinds -> List.map gen_module kinds in
+ let modules = List.map gen_module kinds in
<:str_item<
module type Pp =
sig
- $gen_module_type name (typedefs, excs, funcs, mode)$
+ $gen_module_type name (typedefs, excs, funcs, kinds)$
end
module Pp_pp (P : Pp) : Pp =
View
18 src/generator/parse.ml
@@ -172,7 +172,6 @@ let parse_val loc id t =
type s = {
typedefs : typedefs list;
exceptions : exc list;
- funcs : func list;
module_types : module_type list;
}
@@ -182,15 +181,14 @@ let rec parse_sig_items i a =
| SgSem (_, i1, i2) -> parse_sig_items i1 (parse_sig_items i2 a)
| SgTyp (loc, t) -> { a with typedefs = parse_typedef loc t :: a.typedefs }
| SgExc (loc, t) -> { a with exceptions = parse_exception loc t :: a.exceptions }
- | SgVal (loc, id, t) -> { a with funcs = parse_val loc id t :: a.funcs }
| SgMty (loc, id, MtSig (_, i)) -> { a with module_types = parse_module_type loc id i :: a.module_types }
| <:sig_item@loc< module type Sync = Abstract with type _r 'a = 'a >> ->
{ a with module_types = { mt_loc = loc; mt_kind = Sync; mt_funcs = With } :: a.module_types }
| <:sig_item@loc< module type Async = Abstract with type _r 'a = ((unit -> 'a) -> unit) -> unit >> ->
{ a with module_types = { mt_loc = loc; mt_kind = Async; mt_funcs = With } :: a.module_types }
| <:sig_item@loc< module type Lwt = Abstract with type _r 'a = Lwt.t 'a >> ->
{ a with module_types = { mt_loc = loc; mt_kind = Lwt; mt_funcs = With } :: a.module_types }
- | _ -> sig_item_error i "expected type, function declaration, or module type"
+ | _ -> sig_item_error i "expected type, exception, or module type"
and parse_module_type loc id i =
let seen_return_type = ref false in
@@ -225,13 +223,9 @@ and parse_module_type loc id i =
mt
let parse_interface i =
- let s = { typedefs = []; exceptions = []; funcs = []; module_types = [] } in
+ let s = { typedefs = []; exceptions = []; module_types = [] } in
let s = parse_sig_items i s in
- let { typedefs = typedefs; exceptions = excs; funcs = funcs; module_types = mts } = s in
- match s with
- | { funcs = _::_; module_types = [] } -> (typedefs, excs, funcs, mts) (* simple interface *)
- | { funcs = []; module_types = _::_ } ->
- if List.for_all (function { mt_kind = Ik_abstract } -> true | _ -> false) mts
- then loc_error Loc.ghost "must declare at least one non-Abstract module";
- (typedefs, excs, funcs, mts) (* modules interface *)
- | _ -> loc_error Loc.ghost "expected simple interface or modules interface"
+ let { typedefs = typedefs; exceptions = excs; module_types = mts } = s in
+ if List.for_all (function { mt_kind = Ik_abstract } -> true | _ -> false) mts
+ then loc_error Loc.ghost "must declare at least one non-Abstract module type";
+ (typedefs, excs, mts)
View
6 src/generator/types.ml
@@ -84,11 +84,9 @@ type module_type = {
mt_funcs : mt_funcs;
}
-type pre_interface = typedefs list * exc list * func list * module_type list
+type pre_interface = typedefs list * exc list * module_type list
-type mode = Simple | Modules of interface_kind list
-
-type interface = typedefs list * exc list * func list * mode
+type interface = typedefs list * exc list * func list * interface_kind list
let loc_of_typ = function
| Abstract loc -> loc

0 comments on commit 701c325

Please sign in to comment.