Initial pass at Lwt conversion.
This commit is contained in:
parent
e4dd74ca82
commit
c303ea9d17
|
@ -3,3 +3,9 @@ _build/
|
|||
*.native
|
||||
message.ml
|
||||
amqp_spec.ml
|
||||
|
||||
thirdparty/_dist
|
||||
thirdparty/lwt-2.3.2/setup.data
|
||||
thirdparty/lwt-2.3.2/setup.log
|
||||
thirdparty/lwt-2.3.2/src/unix/lwt_config.h
|
||||
thirdparty/lwt-2.3.2/src/unix/lwt_config.ml
|
||||
|
|
35
Makefile
35
Makefile
|
@ -2,7 +2,28 @@ APP=hop_server
|
|||
TEMPLATES=$(wildcard web/bootstrap/templates/*.xml)
|
||||
HTML=$(subst web/bootstrap/templates/,web/,$(subst .xml,.html,$(TEMPLATES)))
|
||||
|
||||
all: message.ml amqp_spec.ml $(APP).native web/bootstrap/css/bootstrap.css webpages
|
||||
# Augment the path ocamlfind uses to discover installed packages.
|
||||
OCAMLPATH=$(CURDIR)/thirdparty/_dist
|
||||
export OCAMLPATH
|
||||
|
||||
LWT_SRC_DIR=thirdparty/lwt-2.3.2
|
||||
|
||||
all: \
|
||||
thirdparty/_dist \
|
||||
message.ml amqp_spec.ml \
|
||||
$(APP).native \
|
||||
web/bootstrap/css/bootstrap.css \
|
||||
webpages
|
||||
|
||||
thirdparty/_dist:
|
||||
mkdir -p $@
|
||||
(mkdir $@/lwt && \
|
||||
(cd $(LWT_SRC_DIR) && \
|
||||
./configure --disable-libev && \
|
||||
make && \
|
||||
OCAMLFIND_LDCONF=ignore \
|
||||
OCAMLFIND_DESTDIR="$(CURDIR)/$@" \
|
||||
make install))
|
||||
|
||||
webpages: $(HTML)
|
||||
|
||||
|
@ -26,11 +47,19 @@ clean: webclean
|
|||
rm -f message.ml
|
||||
rm -f amqp_spec.ml
|
||||
|
||||
veryclean: clean
|
||||
thirdpartyclean:
|
||||
rm -rf thirdparty/_dist
|
||||
rm -rf $(LWT_SRC_DIR)/_build
|
||||
rm -f $(LWT_SRC_DIR)/setup.data
|
||||
rm -f $(LWT_SRC_DIR)/setup.log
|
||||
rm -f $(LWT_SRC_DIR)/src/unix/lwt_config.h
|
||||
rm -f $(LWT_SRC_DIR)/src/unix/lwt_config.ml
|
||||
|
||||
veryclean: clean thirdpartyclean
|
||||
rm -f web/bootstrap/css/bootstrap.css
|
||||
|
||||
$(APP).native: $(wildcard *.ml)
|
||||
ocamlbuild $@
|
||||
ocamlbuild -use-ocamlfind -X thirdparty $@
|
||||
|
||||
run: all
|
||||
./$(APP).native
|
||||
|
|
5
_tags
5
_tags
|
@ -1,3 +1,4 @@
|
|||
true: use_unix
|
||||
true: package(lwt.unix)
|
||||
true: package(lwt.syntax)
|
||||
true: syntax(camlp4o)
|
||||
true: use_str
|
||||
true: thread
|
||||
|
|
|
@ -15,12 +15,11 @@
|
|||
(* You should have received a copy of the GNU General Public License *)
|
||||
(* along with Hop. If not, see <http://www.gnu.org/licenses/>. *)
|
||||
|
||||
open Lwt
|
||||
open Unix
|
||||
open Printf
|
||||
open Thread
|
||||
open Sexp
|
||||
|
||||
let connection_mtx = Mutex.create ()
|
||||
let connection_count = ref 0
|
||||
|
||||
let endpoint_name n =
|
||||
|
@ -28,49 +27,53 @@ let endpoint_name n =
|
|||
| ADDR_INET (host, port) -> sprintf "%s:%d" (string_of_inet_addr host) port
|
||||
| _ -> "??unknown??"
|
||||
|
||||
let flush_output mtx flush_control cout =
|
||||
let rec loop () =
|
||||
match Event.poll (Event.receive flush_control) with
|
||||
| Some () -> ()
|
||||
| None ->
|
||||
let ok = Util.with_mutex0 mtx (fun () -> try flush cout; true with _ -> false) in
|
||||
if ok then (Thread.delay 0.1; loop ()) else ()
|
||||
in loop ()
|
||||
let flush_output flush_control cout =
|
||||
let keep_running = ref true in
|
||||
Lwt.pick [
|
||||
Lwt_stream.next flush_control;
|
||||
while_lwt !keep_running do
|
||||
try_lwt
|
||||
lwt () = Lwt_io.flush cout in
|
||||
Lwt_unix.sleep 0.1
|
||||
with _ ->
|
||||
keep_running := false;
|
||||
return ()
|
||||
done
|
||||
]
|
||||
|
||||
let connection_main class_name peername cin cout issue_banner boot_fn node_fn mainloop =
|
||||
Log.info ("Accepted "^class_name) [Str (endpoint_name peername)];
|
||||
if issue_banner cin cout
|
||||
then
|
||||
let mtx = Mutex.create () in
|
||||
let flush_control = Event.new_channel () in
|
||||
ignore (Util.create_thread (endpoint_name peername ^ " flush") None
|
||||
(flush_output mtx flush_control) cout);
|
||||
let shared_state = boot_fn (peername, mtx, cin, cout) in
|
||||
let n = Node.make class_name (node_fn shared_state) in
|
||||
(try
|
||||
mainloop shared_state n
|
||||
with
|
||||
| End_of_file ->
|
||||
Log.info ("Disconnecting "^class_name^" normally") [Str (endpoint_name peername)]
|
||||
| Sys_error message ->
|
||||
Log.warn ("Disconnected "^class_name^" by Sys_error")
|
||||
[Str (endpoint_name peername); Str message]
|
||||
| exn ->
|
||||
Log.error ("Uncaught exception in "^class_name) [Str (Printexc.to_string exn)]
|
||||
);
|
||||
Node.unbind_all n;
|
||||
Event.sync (Event.send flush_control ())
|
||||
else
|
||||
Log.error ("Disconnected "^class_name^" by failed initial handshake") []
|
||||
ignore (Log.info ("Accepted "^class_name) [Str (endpoint_name peername)]);
|
||||
match_lwt issue_banner cin cout with
|
||||
| true ->
|
||||
let (flush_control, flush_stop) = Lwt_stream.create () in
|
||||
ignore (flush_output flush_control cout);
|
||||
lwt shared_state = boot_fn (peername, cin, cout) in
|
||||
let n = Node.make class_name (node_fn shared_state) in
|
||||
lwt () =
|
||||
(try_lwt
|
||||
mainloop shared_state n
|
||||
with
|
||||
| End_of_file ->
|
||||
Log.info ("Disconnecting "^class_name^" normally") [Str (endpoint_name peername)]
|
||||
| Sys_error message ->
|
||||
Log.warn ("Disconnected "^class_name^" by Sys_error")
|
||||
[Str (endpoint_name peername); Str message]
|
||||
| exn ->
|
||||
Log.error ("Uncaught exception in "^class_name) [Str (Printexc.to_string exn)])
|
||||
in
|
||||
flush_stop None;
|
||||
Node.unbind_all n
|
||||
| false ->
|
||||
Log.error ("Disconnected "^class_name^" by failed initial handshake") []
|
||||
|
||||
let start_connection' class_name issue_banner boot_fn node_fn mainloop (s, peername) =
|
||||
let cin = in_channel_of_descr s in
|
||||
let cout = out_channel_of_descr s in
|
||||
Util.with_mutex0 connection_mtx (fun () -> connection_count := !connection_count + 1);
|
||||
connection_main class_name peername cin cout issue_banner boot_fn node_fn mainloop;
|
||||
Util.with_mutex0 connection_mtx (fun () -> connection_count := !connection_count - 1);
|
||||
(try flush cout with _ -> ());
|
||||
close s
|
||||
let cin = Lwt_io.of_fd Lwt_io.input s in
|
||||
let cout = Lwt_io.of_fd Lwt_io.output s in
|
||||
connection_count := !connection_count + 1;
|
||||
lwt () = connection_main class_name peername cin cout issue_banner boot_fn node_fn mainloop in
|
||||
connection_count := !connection_count - 1;
|
||||
lwt () = (try_lwt Lwt_io.flush cout with _ -> return ()) in
|
||||
Lwt_unix.close s
|
||||
|
||||
let start_connection class_name issue_banner boot_fn node_fn mainloop (s, peername) =
|
||||
Util.create_thread
|
||||
|
|
|
@ -15,6 +15,7 @@
|
|||
(* You should have received a copy of the GNU General Public License *)
|
||||
(* along with Hop. If not, see <http://www.gnu.org/licenses/>. *)
|
||||
|
||||
open Lwt
|
||||
open Sexp
|
||||
open Datastructures
|
||||
open Status
|
||||
|
@ -22,72 +23,69 @@ open Status
|
|||
type t = {
|
||||
name: Node.name;
|
||||
subscriptions: Subscription.set_t;
|
||||
mtx: Mutex.t;
|
||||
mutable routing_table: UuidSet.t StringMap.t;
|
||||
}
|
||||
|
||||
let classname = "direct"
|
||||
|
||||
let unsubscribe info uuid =
|
||||
Util.with_mutex0 info.mtx
|
||||
(fun () ->
|
||||
match Subscription.delete info.name info.subscriptions uuid with
|
||||
| Some sub ->
|
||||
(match sub.Subscription.filter with
|
||||
| Str binding_key ->
|
||||
(try
|
||||
let old_set = StringMap.find binding_key info.routing_table in
|
||||
let new_set = UuidSet.remove sub.Subscription.uuid old_set in
|
||||
if UuidSet.is_empty new_set
|
||||
then info.routing_table <- StringMap.remove binding_key info.routing_table
|
||||
else info.routing_table <- StringMap.add binding_key new_set info.routing_table
|
||||
with Not_found ->
|
||||
())
|
||||
| _ -> ())
|
||||
| None -> ())
|
||||
match_lwt Subscription.delete info.name info.subscriptions uuid with
|
||||
| Some sub ->
|
||||
(match sub.Subscription.filter with
|
||||
| Str binding_key ->
|
||||
(try
|
||||
let old_set = StringMap.find binding_key info.routing_table in
|
||||
let new_set = UuidSet.remove sub.Subscription.uuid old_set in
|
||||
if UuidSet.is_empty new_set
|
||||
then info.routing_table <- StringMap.remove binding_key info.routing_table
|
||||
else info.routing_table <- StringMap.add binding_key new_set info.routing_table
|
||||
with Not_found ->
|
||||
());
|
||||
return ()
|
||||
| _ -> return ())
|
||||
| None -> return ()
|
||||
|
||||
let route_message info n sexp =
|
||||
match Message.message_of_sexp sexp with
|
||||
| Message.Post (Str name, body, token) ->
|
||||
| Message.Post (Str name, body, token) ->
|
||||
let routing_snapshot = info.routing_table in
|
||||
let matching = (try StringMap.find name routing_snapshot with Not_found -> UuidSet.empty) in
|
||||
UuidSet.iter
|
||||
Lwt_list.iter_s
|
||||
(fun (uuid) ->
|
||||
match Subscription.lookup info.subscriptions uuid with
|
||||
| Some sub ->
|
||||
ignore (Subscription.send_to_subscription' sub body (unsubscribe info))
|
||||
| None ->
|
||||
())
|
||||
matching
|
||||
| Message.Subscribe (Str binding_key as filter, Str sink, name, Str reply_sink, reply_name) ->
|
||||
Util.with_mutex0 info.mtx
|
||||
(fun () ->
|
||||
let sub =
|
||||
Subscription.create
|
||||
info.name info.subscriptions filter sink name reply_sink reply_name in
|
||||
let old_set =
|
||||
(try StringMap.find binding_key info.routing_table with Not_found -> UuidSet.empty) in
|
||||
let new_set = UuidSet.add sub.Subscription.uuid old_set in
|
||||
info.routing_table <- StringMap.add binding_key new_set info.routing_table)
|
||||
| Message.Unsubscribe (Str token) ->
|
||||
| Some sub ->
|
||||
lwt _ = Subscription.send_to_subscription' sub body (unsubscribe info) in
|
||||
return ()
|
||||
| None ->
|
||||
return ())
|
||||
(UuidSet.elements matching)
|
||||
| Message.Subscribe (Str binding_key as filter, Str sink, name, Str reply_sink, reply_name) ->
|
||||
lwt sub =
|
||||
Subscription.create
|
||||
info.name info.subscriptions filter sink name reply_sink reply_name in
|
||||
let old_set =
|
||||
(try StringMap.find binding_key info.routing_table with Not_found -> UuidSet.empty) in
|
||||
let new_set = UuidSet.add sub.Subscription.uuid old_set in
|
||||
info.routing_table <- StringMap.add binding_key new_set info.routing_table;
|
||||
return ()
|
||||
| Message.Unsubscribe (Str token) ->
|
||||
unsubscribe info token
|
||||
| m ->
|
||||
| m ->
|
||||
Util.message_not_understood classname m
|
||||
|
||||
let factory arg =
|
||||
match arg with
|
||||
| (Arr [Str name_str]) ->
|
||||
| (Arr [Str name_str]) ->
|
||||
let info = {
|
||||
name = Node.name_of_string name_str;
|
||||
subscriptions = Subscription.new_set ();
|
||||
mtx = Mutex.create ();
|
||||
routing_table = StringMap.empty;
|
||||
} in
|
||||
replace_ok
|
||||
(Node.make_idempotent_named classname info.name (route_message info))
|
||||
(Str name_str)
|
||||
| _ ->
|
||||
Problem (Str "bad-arg")
|
||||
| _ ->
|
||||
return (Problem (Str "bad-arg"))
|
||||
|
||||
let init () =
|
||||
Factory.register_class classname factory
|
||||
|
|
46
factory.ml
46
factory.ml
|
@ -15,23 +15,23 @@
|
|||
(* You should have received a copy of the GNU General Public License *)
|
||||
(* along with Hop. If not, see <http://www.gnu.org/licenses/>. *)
|
||||
|
||||
open Lwt
|
||||
open Printf
|
||||
open Sexp
|
||||
open Datastructures
|
||||
|
||||
type factory_t = Sexp.t -> (Sexp.t, Sexp.t) Status.t
|
||||
type factory_t = Sexp.t -> (Sexp.t, Sexp.t) Status.t Lwt.t
|
||||
|
||||
let mutex = Mutex.create ()
|
||||
let classes = ref StringMap.empty
|
||||
|
||||
let register_class name factory =
|
||||
Util.with_mutex0 mutex
|
||||
(fun () ->
|
||||
if StringMap.mem name !classes
|
||||
then (Log.error "Duplicate node class name" [Str name];
|
||||
exit 1)
|
||||
else (Log.info "Registered node class" [Str name];
|
||||
classes := StringMap.add name factory !classes))
|
||||
if StringMap.mem name !classes
|
||||
then (ignore (Log.error "Duplicate node class name" [Str name]);
|
||||
Server_control.shutdown_now [Str "Duplicate node class name"; Str name];
|
||||
Lwt_unix.yield ())
|
||||
else (ignore (Log.info "Registered node class" [Str name]);
|
||||
classes := StringMap.add name factory !classes;
|
||||
return ())
|
||||
|
||||
let all_class_names () =
|
||||
Datastructures.string_map_keys !classes
|
||||
|
@ -43,21 +43,21 @@ let lookup_class name =
|
|||
let factory_handler n sexp =
|
||||
match Message.message_of_sexp sexp with
|
||||
| Message.Create (Str classname, arg, Str reply_sink, Str reply_name) ->
|
||||
let reply =
|
||||
lwt reply =
|
||||
match lookup_class classname with
|
||||
| Some factory ->
|
||||
(match factory arg with
|
||||
| Status.Ok info ->
|
||||
Log.info "Node create ok"
|
||||
[Str classname; arg; Str reply_sink; Str reply_name; info];
|
||||
Message.create_ok info
|
||||
| Status.Problem explanation ->
|
||||
Log.info "Node create failed"
|
||||
[Str classname; arg; Str reply_sink; Str reply_name; explanation];
|
||||
Message.create_failed (Arr [Str "constructor"; explanation]))
|
||||
| None ->
|
||||
Log.warn "Node class not found" [Str classname];
|
||||
Message.create_failed (Arr [Str "factory"; Str "class-not-found"])
|
||||
| Some factory ->
|
||||
(match_lwt factory arg with
|
||||
| Status.Ok info ->
|
||||
ignore (Log.info "Node create ok"
|
||||
[Str classname; arg; Str reply_sink; Str reply_name; info]);
|
||||
return (Message.create_ok info)
|
||||
| Status.Problem explanation ->
|
||||
ignore (Log.info "Node create failed"
|
||||
[Str classname; arg; Str reply_sink; Str reply_name; explanation]);
|
||||
return (Message.create_failed (Arr [Str "constructor"; explanation])))
|
||||
| None ->
|
||||
ignore (Log.warn "Node class not found" [Str classname]);
|
||||
return (Message.create_failed (Arr [Str "factory"; Str "class-not-found"]))
|
||||
in
|
||||
Node.post_ignore' reply_sink (Str reply_name) reply (Str "")
|
||||
| m ->
|
||||
|
|
|
@ -15,6 +15,7 @@
|
|||
(* You should have received a copy of the GNU General Public License *)
|
||||
(* along with Hop. If not, see <http://www.gnu.org/licenses/>. *)
|
||||
|
||||
open Lwt
|
||||
open Sexp
|
||||
open Datastructures
|
||||
open Status
|
||||
|
@ -22,46 +23,42 @@ open Status
|
|||
type t = {
|
||||
name: Node.name;
|
||||
subscriptions: Subscription.set_t;
|
||||
mtx: Mutex.t;
|
||||
}
|
||||
|
||||
let classname = "fanout"
|
||||
|
||||
let unsubscribe info uuid =
|
||||
Util.with_mutex0 info.mtx
|
||||
(fun () -> ignore (Subscription.delete info.name info.subscriptions uuid))
|
||||
lwt _ = Subscription.delete info.name info.subscriptions uuid in return ()
|
||||
|
||||
let route_message info n sexp =
|
||||
match Message.message_of_sexp sexp with
|
||||
| Message.Post (Str name, body, token) ->
|
||||
| Message.Post (Str name, body, token) ->
|
||||
let snapshot = !(info.subscriptions) in
|
||||
StringMap.iter
|
||||
(fun uuid sub ->
|
||||
ignore (Subscription.send_to_subscription' sub body (unsubscribe info)))
|
||||
snapshot
|
||||
| Message.Subscribe (Str binding_key as filter, Str sink, name, Str reply_sink, reply_name) ->
|
||||
Util.with_mutex0 info.mtx
|
||||
(fun () ->
|
||||
ignore (Subscription.create
|
||||
info.name info.subscriptions filter sink name reply_sink reply_name))
|
||||
| Message.Unsubscribe (Str token) ->
|
||||
Lwt_list.iter_s
|
||||
(fun (uuid, sub) ->
|
||||
lwt _ = Subscription.send_to_subscription' sub body (unsubscribe info) in return ())
|
||||
(StringMap.bindings snapshot)
|
||||
| Message.Subscribe (Str binding_key as filter, Str sink, name, Str reply_sink, reply_name) ->
|
||||
lwt _ = (Subscription.create
|
||||
info.name info.subscriptions filter sink name reply_sink reply_name) in
|
||||
return ()
|
||||
| Message.Unsubscribe (Str token) ->
|
||||
unsubscribe info token
|
||||
| m ->
|
||||
| m ->
|
||||
Util.message_not_understood classname m
|
||||
|
||||
let factory arg =
|
||||
match arg with
|
||||
| (Arr [Str name_str]) ->
|
||||
| (Arr [Str name_str]) ->
|
||||
let info = {
|
||||
name = Node.name_of_string name_str;
|
||||
subscriptions = Subscription.new_set ();
|
||||
mtx = Mutex.create ();
|
||||
subscriptions = Subscription.new_set ()
|
||||
} in
|
||||
replace_ok
|
||||
(Node.make_idempotent_named classname info.name (route_message info))
|
||||
(Str name_str)
|
||||
| _ ->
|
||||
Problem (Str "bad-arg")
|
||||
| _ ->
|
||||
return (Problem (Str "bad-arg"))
|
||||
|
||||
let init () =
|
||||
Factory.register_class classname factory
|
||||
|
|
|
@ -15,6 +15,8 @@
|
|||
(* You should have received a copy of the GNU General Public License *)
|
||||
(* along with Hop. If not, see <http://www.gnu.org/licenses/>. *)
|
||||
|
||||
open Lwt
|
||||
|
||||
let n_system_log = Node.name_of_string "system.log"
|
||||
|
||||
let hook_log () =
|
||||
|
@ -27,33 +29,33 @@ let hook_log () =
|
|||
|
||||
let create_ready_file () =
|
||||
match Config.get "ready-file" with
|
||||
| Some ready_file_path ->
|
||||
Log.info "Creating ready file" [Sexp.Str ready_file_path];
|
||||
close_out (open_out ready_file_path)
|
||||
| None ->
|
||||
()
|
||||
| Some ready_file_path ->
|
||||
ignore (Log.info "Creating ready file" [Sexp.Str ready_file_path]);
|
||||
return (close_out (open_out ready_file_path))
|
||||
| None ->
|
||||
return ()
|
||||
|
||||
let _ =
|
||||
lwt _ =
|
||||
Printf.printf "%s %s, %s\n%s\n%!"
|
||||
App_info.product App_info.version App_info.copyright App_info.licence_blurb;
|
||||
Sys.set_signal Sys.sigpipe Sys.Signal_ignore;
|
||||
Uuid.init ();
|
||||
Config.init ();
|
||||
Factory.init ();
|
||||
Queuenode.init ();
|
||||
Fanoutnode.init ();
|
||||
Directnode.init ();
|
||||
Meta.init ();
|
||||
lwt () = Factory.init () in
|
||||
lwt () = Queuenode.init () in
|
||||
lwt () = Fanoutnode.init () in
|
||||
lwt () = Directnode.init () in
|
||||
lwt () = Meta.init () in
|
||||
hook_log ();
|
||||
Amqp_relay.init ();
|
||||
Ui_main.init ();
|
||||
Ui_relay.init ();
|
||||
(* Amqp_relay.init ();
|
||||
Ui_main.init ();
|
||||
Ui_relay.init (); *)
|
||||
Relay.init ();
|
||||
Server_control.run_until "AMQP ready";
|
||||
Server_control.run_until "HTTP ready";
|
||||
Server_control.run_until "Hop ready";
|
||||
(* Server_control.run_until "AMQP ready";
|
||||
Server_control.run_until "HTTP ready"; *)
|
||||
lwt () = Server_control.run_until "Hop ready" in
|
||||
if Server_control.is_running ()
|
||||
then (create_ready_file ();
|
||||
then (lwt () = create_ready_file () in
|
||||
Server_control.milestone "Server initialized";
|
||||
Server_control.run_forever ())
|
||||
else ()
|
||||
else return ()
|
||||
|
|
16
log.ml
16
log.ml
|
@ -15,18 +15,16 @@
|
|||
(* You should have received a copy of the GNU General Public License *)
|
||||
(* along with Hop. If not, see <http://www.gnu.org/licenses/>. *)
|
||||
|
||||
open Lwt
|
||||
open Sexp
|
||||
|
||||
let mtx = Mutex.create ()
|
||||
let write_to_log label body =
|
||||
Mutex.lock mtx;
|
||||
(try
|
||||
print_string label;
|
||||
print_string ": ";
|
||||
output_sexp_human stdout body;
|
||||
print_newline ()
|
||||
with _ -> ());
|
||||
Mutex.unlock mtx
|
||||
try_lwt
|
||||
lwt () = Lwt_io.print label in
|
||||
lwt () = Lwt_io.print ": " in
|
||||
lwt () = output_sexp_human Lwt_io.stdout body in
|
||||
Lwt_io.printl ""
|
||||
with _ -> return ()
|
||||
|
||||
let hook = ref write_to_log
|
||||
|
||||
|
|
15
net.ml
15
net.ml
|
@ -15,19 +15,20 @@
|
|||
(* You should have received a copy of the GNU General Public License *)
|
||||
(* along with Hop. If not, see <http://www.gnu.org/licenses/>. *)
|
||||
|
||||
open Unix
|
||||
open Lwt_unix
|
||||
|
||||
let rec accept_loop sock connection_start_fn =
|
||||
let (s, peername) = accept sock in
|
||||
setsockopt s TCP_NODELAY true;
|
||||
lwt (s, peername) = accept sock in
|
||||
setsockopt s Unix.TCP_NODELAY true;
|
||||
ignore (connection_start_fn (s, peername));
|
||||
accept_loop sock connection_start_fn
|
||||
|
||||
let start_net protocol_name port_number connection_start_fn =
|
||||
let sock = socket PF_INET SOCK_STREAM 0 in
|
||||
setsockopt sock SO_REUSEADDR true;
|
||||
bind sock (ADDR_INET (inet_addr_of_string "0.0.0.0", port_number));
|
||||
let sock = socket Unix.PF_INET Unix.SOCK_STREAM 0 in
|
||||
setsockopt sock Unix.SO_REUSEADDR true;
|
||||
bind sock (Unix.ADDR_INET (Unix.inet_addr_any, port_number));
|
||||
listen sock 5;
|
||||
Server_control.milestone (protocol_name ^ " ready");
|
||||
Log.info "Accepting connections" [Sexp.Str protocol_name; Sexp.Str (string_of_int port_number)];
|
||||
ignore (Log.info "Accepting connections"
|
||||
[Sexp.Str protocol_name; Sexp.Str (string_of_int port_number)]);
|
||||
accept_loop sock connection_start_fn
|
||||
|
|
91
node.ml
91
node.ml
|
@ -15,11 +15,12 @@
|
|||
(* You should have received a copy of the GNU General Public License *)
|
||||
(* along with Hop. If not, see <http://www.gnu.org/licenses/>. *)
|
||||
|
||||
open Lwt
|
||||
open Printf
|
||||
open Datastructures
|
||||
open Status
|
||||
|
||||
type handle_message_t = t -> Sexp.t -> unit
|
||||
type handle_message_t = t -> Sexp.t -> unit Lwt.t
|
||||
and t = {
|
||||
mutable names: StringSet.t;
|
||||
class_name: string;
|
||||
|
@ -40,14 +41,12 @@ module NameSet = Set.Make(struct
|
|||
let compare a b = String.compare a.label b.label
|
||||
end)
|
||||
|
||||
let mutex = Mutex.create ()
|
||||
let name_table = NameTable.create 100
|
||||
let directory = ref NameSet.empty
|
||||
|
||||
let name_of_string str =
|
||||
Util.with_mutex0 mutex (fun () ->
|
||||
let template = {label = str; binding = None} in
|
||||
NameTable.merge name_table template)
|
||||
let template = {label = str; binding = None} in
|
||||
NameTable.merge name_table template
|
||||
|
||||
let local_container_name () = "server"
|
||||
|
||||
|
@ -70,57 +69,66 @@ let approx_exists name =
|
|||
|
||||
let bind (filter, node) =
|
||||
if filter.label = ""
|
||||
then (Log.warn "Binding to empty name forbidden" []; false)
|
||||
then (ignore (Log.warn "Binding to empty name forbidden" []); return false)
|
||||
else
|
||||
Util.with_mutex0 mutex (fun () ->
|
||||
filter.binding <- Some node;
|
||||
directory := NameSet.add filter !directory;
|
||||
node.names <- StringSet.add filter.label node.names;
|
||||
Log.info "Node bound" [Sexp.Str filter.label; Sexp.Str node.class_name];
|
||||
true)
|
||||
(filter.binding <- Some node;
|
||||
directory := NameSet.add filter !directory;
|
||||
node.names <- StringSet.add filter.label node.names;
|
||||
ignore (Log.info "Node bound" [Sexp.Str filter.label; Sexp.Str node.class_name]);
|
||||
return true)
|
||||
|
||||
(* For use in factory constructor functions, hence the odd return type and values *)
|
||||
let make_named class_name node_name handler =
|
||||
let node = make class_name handler in
|
||||
if bind (node_name, node) then Ok node else Problem (Sexp.Str "bind-failed")
|
||||
match_lwt bind (node_name, node) with
|
||||
| true -> return (Ok node)
|
||||
| false -> return (Problem (Sexp.Str "bind-failed"))
|
||||
|
||||
(* For use in factory constructor functions, hence the odd return type and values *)
|
||||
let make_idempotent_named class_name node_name handler =
|
||||
match lookup node_name with
|
||||
| Some n ->
|
||||
if n.class_name = class_name
|
||||
return (if n.class_name = class_name
|
||||
then Ok n
|
||||
else Problem (Sexp.Str "class-mismatch")
|
||||
else Problem (Sexp.Str "class-mismatch"))
|
||||
| None ->
|
||||
let node = make class_name handler in
|
||||
if bind (node_name, node) then Ok node else Problem (Sexp.Str "bind-failed")
|
||||
match_lwt bind (node_name, node) with
|
||||
| true -> return (Ok node)
|
||||
| false -> return (Problem (Sexp.Str "bind-failed"))
|
||||
|
||||
let unbind name =
|
||||
Util.with_mutex0 mutex (fun () ->
|
||||
match lookup name with
|
||||
match lookup name with
|
||||
| Some n ->
|
||||
Log.info "Node unbound" [Sexp.Str name.label; Sexp.Str n.class_name];
|
||||
n.names <- StringSet.remove name.label n.names;
|
||||
name.binding <- None;
|
||||
directory := NameSet.remove name !directory;
|
||||
true
|
||||
ignore (Log.info "Node unbound" [Sexp.Str name.label; Sexp.Str n.class_name]);
|
||||
n.names <- StringSet.remove name.label n.names;
|
||||
name.binding <- None;
|
||||
directory := NameSet.remove name !directory;
|
||||
return true
|
||||
| None ->
|
||||
false)
|
||||
return false
|
||||
|
||||
let unbind_all n =
|
||||
StringSet.iter (fun name -> ignore (unbind (name_of_string name))) n.names;
|
||||
n.names <- StringSet.empty
|
||||
lwt () =
|
||||
Lwt_list.iter_s
|
||||
(fun name -> lwt _ = unbind (name_of_string name) in return ())
|
||||
(StringSet.elements n.names)
|
||||
in
|
||||
n.names <- StringSet.empty;
|
||||
return ()
|
||||
|
||||
let send name body =
|
||||
match lookup name with
|
||||
| Some n ->
|
||||
(try n.handle_message n body
|
||||
with e ->
|
||||
Log.warn "Node message handler raised exception"
|
||||
[Sexp.Str name.label;
|
||||
Sexp.Str (Printexc.to_string e)]);
|
||||
true
|
||||
| None -> false
|
||||
| Some n ->
|
||||
ignore
|
||||
(try_lwt n.handle_message n body
|
||||
with e ->
|
||||
Log.warn "Node message handler raised exception"
|
||||
[Sexp.Str name.label;
|
||||
Sexp.Str (Printexc.to_string e)]);
|
||||
return true
|
||||
| None ->
|
||||
return false
|
||||
|
||||
let send' str body = send (name_of_string str) body
|
||||
|
||||
|
@ -130,14 +138,17 @@ let post name label body token =
|
|||
let post' str label body token = post (name_of_string str) label body token
|
||||
|
||||
let bind_ignore (filter, node) =
|
||||
if bind (filter, node)
|
||||
then ()
|
||||
else Log.warn "Duplicate binding" [Sexp.Str filter.label]
|
||||
match_lwt bind (filter, node) with
|
||||
| true -> return ()
|
||||
| false -> Log.warn "Duplicate binding" [Sexp.Str filter.label]
|
||||
|
||||
let send_ignore name body =
|
||||
if send name body || name.label = ""
|
||||
then ()
|
||||
else Log.warn "send to missing node" [Sexp.Str name.label; body]
|
||||
match_lwt send name body with
|
||||
| true -> return ()
|
||||
| false ->
|
||||
if name.label = ""
|
||||
then return ()
|
||||
else Log.warn "send to missing node" [Sexp.Str name.label; body]
|
||||
|
||||
let send_ignore' str body = send_ignore (name_of_string str) body
|
||||
|
||||
|
|
116
queuenode.ml
116
queuenode.ml
|
@ -15,87 +15,87 @@
|
|||
(* You should have received a copy of the GNU General Public License *)
|
||||
(* along with Hop. If not, see <http://www.gnu.org/licenses/>. *)
|
||||
|
||||
open Lwt
|
||||
open Sexp
|
||||
open Status
|
||||
|
||||
(* TODO: on unsubscribe, wake up the shoveller to make it clean out its waiters queue *)
|
||||
|
||||
type t = {
|
||||
name: Node.name;
|
||||
subscriptions: Subscription.set_t;
|
||||
ch: Message.t Squeue.t;
|
||||
mutable backlog: Sexp.t Queue.t;
|
||||
mutable waiters: Subscription.t Queue.t;
|
||||
}
|
||||
name: Node.name;
|
||||
subscriptions: Subscription.set_t;
|
||||
backlog_in: Sexp.t Lwt_stream.t;
|
||||
backlog_out: Sexp.t option -> unit;
|
||||
waiters_in: Subscription.t Lwt_stream.t;
|
||||
waiters_out: Subscription.t option -> unit;
|
||||
mutable backlog: int;
|
||||
mutable waiters: int;
|
||||
}
|
||||
|
||||
let classname = "queue"
|
||||
|
||||
let report info n =
|
||||
Log.info (Printf.sprintf "do_burst %d capacity, %d backlog, %d waiters, %d ticks left\n%!"
|
||||
(Squeue.approx_capacity info.ch)
|
||||
(Queue.length info.backlog)
|
||||
(Queue.length info.waiters)
|
||||
Log.info (Printf.sprintf "do_burst %d backlog, %d waiters, %d ticks left\n%!"
|
||||
info.backlog
|
||||
info.waiters
|
||||
n) []
|
||||
|
||||
let rec do_burst info n =
|
||||
(* report info n; *)
|
||||
if Queue.is_empty info.backlog then false
|
||||
else
|
||||
if Queue.is_empty info.waiters then false
|
||||
else
|
||||
if n = 0 then true (* maybe more work available, but should poll for outside events *)
|
||||
else
|
||||
let body = Queue.peek info.backlog in
|
||||
let sub = Queue.pop info.waiters in
|
||||
if Subscription.send_to_subscription info.name info.subscriptions sub body
|
||||
then
|
||||
(Queue.push sub info.waiters;
|
||||
ignore (Queue.pop info.backlog);
|
||||
do_burst info (n - 1))
|
||||
else
|
||||
do_burst info n
|
||||
|
||||
let rec process_and_wait info =
|
||||
if not (do_burst info 1000)
|
||||
then Squeue.pop info.ch
|
||||
else
|
||||
match Squeue.peek info.ch with
|
||||
| Some m -> m
|
||||
| None -> process_and_wait info
|
||||
|
||||
let shoveller info =
|
||||
let rec loop () =
|
||||
match process_and_wait info with
|
||||
let rec message_loop () =
|
||||
lwt body = Lwt_stream.next info.backlog_in in
|
||||
let rec waiter_loop () =
|
||||
lwt sub = Lwt_stream.next info.waiters_in in
|
||||
match_lwt Subscription.send_to_subscription info.name info.subscriptions sub body with
|
||||
| true ->
|
||||
info.backlog <- info.backlog - 1;
|
||||
info.waiters_out (Some sub);
|
||||
message_loop ()
|
||||
| false ->
|
||||
waiter_loop ()
|
||||
in waiter_loop ()
|
||||
in message_loop ()
|
||||
|
||||
let queue_handler info n sexp =
|
||||
match Message.message_of_sexp sexp with
|
||||
| Message.Post (name, body, token) ->
|
||||
Queue.push body info.backlog;
|
||||
loop ()
|
||||
info.backlog <- info.backlog + 1;
|
||||
info.backlog_out (Some body);
|
||||
return ()
|
||||
| Message.Subscribe (filter, Str sink, name, Str reply_sink, reply_name) ->
|
||||
let sub =
|
||||
Subscription.create
|
||||
info.name info.subscriptions filter sink name reply_sink reply_name in
|
||||
Queue.push sub info.waiters;
|
||||
loop ()
|
||||
lwt sub =
|
||||
Subscription.create
|
||||
info.name info.subscriptions filter sink name reply_sink reply_name in
|
||||
info.waiters <- info.waiters + 1;
|
||||
info.waiters_out (Some sub);
|
||||
return ()
|
||||
| Message.Unsubscribe (Str token) ->
|
||||
ignore (Subscription.delete info.name info.subscriptions token);
|
||||
loop ()
|
||||
ignore (Subscription.delete info.name info.subscriptions token);
|
||||
info.waiters <- info.waiters - 1;
|
||||
return ()
|
||||
| m ->
|
||||
Util.message_not_understood "queue" m;
|
||||
loop ()
|
||||
in loop ()
|
||||
Util.message_not_understood "queue" m
|
||||
|
||||
let queue_factory arg =
|
||||
match arg with
|
||||
| (Arr [Str name_str]) ->
|
||||
| (Arr [Str name_str]) ->
|
||||
let (bin, bout) = Lwt_stream.create () in
|
||||
let (win, wout) = Lwt_stream.create () in
|
||||
let info = {
|
||||
name = Node.name_of_string name_str;
|
||||
subscriptions = Subscription.new_set ();
|
||||
ch = Squeue.create 1000;
|
||||
backlog = Queue.create ();
|
||||
waiters = Queue.create ()
|
||||
backlog_in = bin;
|
||||
backlog_out = bout;
|
||||
waiters_in = win;
|
||||
waiters_out = wout;
|
||||
backlog = 0;
|
||||
waiters = 0
|
||||
} in
|
||||
ignore (Util.create_thread name_str None shoveller info);
|
||||
let queue_handler n sexp = Squeue.add (Message.message_of_sexp sexp) info.ch in
|
||||
replace_ok (Node.make_idempotent_named classname info.name queue_handler) (Str name_str)
|
||||
| _ ->
|
||||
Problem (Str "bad-arg")
|
||||
replace_ok
|
||||
(Node.make_idempotent_named classname info.name (queue_handler info))
|
||||
(Str name_str)
|
||||
| _ ->
|
||||
return (Problem (Str "bad-arg"))
|
||||
|
||||
let init () =
|
||||
Factory.register_class classname queue_factory
|
||||
|
|
69
relay.ml
69
relay.ml
|
@ -15,14 +15,14 @@
|
|||
(* You should have received a copy of the GNU General Public License *)
|
||||
(* along with Hop. If not, see <http://www.gnu.org/licenses/>. *)
|
||||
|
||||
open Lwt
|
||||
open Unix
|
||||
open Printf
|
||||
open Thread
|
||||
open Sexp
|
||||
|
||||
let send_error ch message details =
|
||||
let m = Message.error (Str message, details) in
|
||||
Log.warn "Sending error" [m];
|
||||
ignore (Log.warn "Sending error" [m]);
|
||||
ch m
|
||||
|
||||
let send_sexp_syntax_error ch explanation =
|
||||
|
@ -30,48 +30,51 @@ let send_sexp_syntax_error ch explanation =
|
|||
|
||||
let dispatch_message n ch m =
|
||||
match m with
|
||||
| Message.Post (Str name, body, token) ->
|
||||
| Message.Post (Str name, body, token) ->
|
||||
Node.send_ignore' name body
|
||||
| Message.Subscribe (Str filter, sink, name, Str reply_sink, Str reply_name) ->
|
||||
if Node.bind (Node.name_of_string filter, n)
|
||||
then Node.post_ignore'
|
||||
reply_sink
|
||||
(Str reply_name)
|
||||
(Message.subscribe_ok (Str filter))
|
||||
(Str "")
|
||||
else Log.warn "Bind failed" [Str filter]
|
||||
| Message.Unsubscribe (Str token) ->
|
||||
if Node.unbind (Node.name_of_string token)
|
||||
then ()
|
||||
else Log.warn "Unbind failed" [Str token]
|
||||
| _ ->
|
||||
| Message.Subscribe (Str filter, sink, name, Str reply_sink, Str reply_name) ->
|
||||
(match_lwt Node.bind (Node.name_of_string filter, n) with
|
||||
| true ->
|
||||
Node.post_ignore'
|
||||
reply_sink
|
||||
(Str reply_name)
|
||||
(Message.subscribe_ok (Str filter))
|
||||
(Str "")
|
||||
| false ->
|
||||
Log.warn "Bind failed" [Str filter])
|
||||
| Message.Unsubscribe (Str token) ->
|
||||
(match_lwt Node.unbind (Node.name_of_string token) with
|
||||
| true -> return ()
|
||||
| false -> Log.warn "Unbind failed" [Str token])
|
||||
| _ ->
|
||||
send_error ch "Message not understood" (Message.sexp_of_message m)
|
||||
|
||||
let issue_banner cin cout =
|
||||
output_sexp_and_flush cout (Arr [Str "hop"; Str ""]);
|
||||
output_sexp_and_flush cout
|
||||
(Message.subscribe (Str (Node.local_container_name()),
|
||||
Str "", Str "",
|
||||
Str "", Str ""));
|
||||
true
|
||||
lwt () = output_sexp_and_flush cout (Arr [Str "hop"; Str ""]) in
|
||||
lwt () =
|
||||
output_sexp_and_flush cout
|
||||
(Message.subscribe (Str (Node.local_container_name()),
|
||||
Str "", Str "",
|
||||
Str "", Str "")) in
|
||||
return true
|
||||
|
||||
let relay_boot (peername, mtx, cin, cout) = (peername, mtx, cin, cout)
|
||||
let relay_boot (peername, cin, cout) = return (peername, Lwt_mutex.create (), cin, cout)
|
||||
|
||||
let relay_handler (_, mtx, _, cout) _ m =
|
||||
Util.with_mutex mtx (output_sexp_and_flush cout) m
|
||||
Lwt_mutex.with_lock mtx (fun () -> output_sexp_and_flush cout m)
|
||||
|
||||
let relay_mainloop (peername, mtx, cin, cout) n =
|
||||
let write_sexp = Util.with_mutex mtx (output_sexp cout) in
|
||||
(try
|
||||
while true do
|
||||
dispatch_message n write_sexp (Message.message_of_sexp (Sexp.input_sexp cin))
|
||||
done
|
||||
with
|
||||
| Sexp.Syntax_error explanation ->
|
||||
(send_sexp_syntax_error write_sexp explanation;
|
||||
let write_sexp sexp = Lwt_mutex.with_lock mtx (fun () -> output_sexp cout sexp) in
|
||||
(try_lwt
|
||||
while_lwt true do
|
||||
lwt message_sexp = Sexp.input_sexp cin in
|
||||
dispatch_message n write_sexp (Message.message_of_sexp message_sexp)
|
||||
done
|
||||
with
|
||||
| Sexp.Syntax_error explanation ->
|
||||
lwt () = send_sexp_syntax_error write_sexp explanation in
|
||||
Log.info "Disconnected relay for syntax error"
|
||||
[Str (Connections.endpoint_name peername); Str explanation])
|
||||
)
|
||||
|
||||
let start (s, peername) =
|
||||
Connections.start_connection "relay" issue_banner
|
||||
|
|
|
@ -15,18 +15,17 @@
|
|||
(* You should have received a copy of the GNU General Public License *)
|
||||
(* along with Hop. If not, see <http://www.gnu.org/licenses/>. *)
|
||||
|
||||
open Lwt
|
||||
open Datastructures
|
||||
|
||||
let continue_running = ref true
|
||||
let control_queue = Squeue.create 1
|
||||
let (cq_in, cq_out) = Lwt_stream.create ()
|
||||
|
||||
let achieved_milestones = ref StringSet.empty
|
||||
|
||||
let milestone name =
|
||||
Squeue.add (`Milestone name) control_queue
|
||||
let milestone name = cq_out (Some (`Milestone name))
|
||||
|
||||
let shutdown_now details =
|
||||
Squeue.add (`Shutdown details) control_queue
|
||||
let shutdown_now details = cq_out (Some (`Shutdown details))
|
||||
|
||||
let is_milestone_achieved m =
|
||||
match m with
|
||||
|
@ -37,16 +36,16 @@ let is_milestone_achieved m =
|
|||
|
||||
let rec run' until_milestone =
|
||||
match is_milestone_achieved until_milestone with
|
||||
| true ->
|
||||
()
|
||||
| false ->
|
||||
(match Squeue.pop control_queue with
|
||||
| `Shutdown details ->
|
||||
Log.error "Shutting down server" details;
|
||||
| true ->
|
||||
return ()
|
||||
| false ->
|
||||
(match_lwt Lwt_stream.next cq_in with
|
||||
| `Shutdown details ->
|
||||
ignore (Log.error "Shutting down server" details);
|
||||
continue_running := false;
|
||||
()
|
||||
| `Milestone name ->
|
||||
Log.info "Achieved milestone" [Sexp.Str name];
|
||||
return ()
|
||||
| `Milestone name ->
|
||||
ignore (Log.info "Achieved milestone" [Sexp.Str name]);
|
||||
achieved_milestones := StringSet.add name !achieved_milestones;
|
||||
run' until_milestone)
|
||||
|
||||
|
@ -54,11 +53,11 @@ let is_running () = !continue_running
|
|||
|
||||
let run_until milestone =
|
||||
if !continue_running
|
||||
then (Log.info "Waiting for milestone" [Sexp.Str milestone];
|
||||
then (ignore (Log.info "Waiting for milestone" [Sexp.Str milestone]);
|
||||
run' (Some milestone))
|
||||
else ()
|
||||
else return ()
|
||||
|
||||
let run_forever () =
|
||||
if !continue_running
|
||||
then run' None
|
||||
else ()
|
||||
else return ()
|
||||
|
|
131
sexp.ml
131
sexp.ml
|
@ -17,6 +17,9 @@
|
|||
|
||||
(* SPKI SEXP *)
|
||||
|
||||
open Lwt
|
||||
open Lwt_io
|
||||
|
||||
exception Syntax_error of string
|
||||
|
||||
type display_hint_t = {hint : t; body : t}
|
||||
|
@ -26,23 +29,23 @@ and t =
|
|||
| Arr of t list
|
||||
|
||||
let _output_str ch s =
|
||||
output_string ch (string_of_int (String.length s));
|
||||
output_char ch ':';
|
||||
output_string ch s
|
||||
lwt () = write ch (string_of_int (String.length s)) in
|
||||
lwt () = write_char ch ':' in
|
||||
write ch s
|
||||
|
||||
let rec output_sexp ch x =
|
||||
match x with
|
||||
| Str s ->
|
||||
| Str s ->
|
||||
_output_str ch s
|
||||
| Hint {hint = h; body = b} ->
|
||||
output_char ch '[';
|
||||
output_sexp ch h;
|
||||
output_char ch ']';
|
||||
| Hint {hint = h; body = b} ->
|
||||
lwt () = write_char ch '[' in
|
||||
lwt () = output_sexp ch h in
|
||||
lwt () = write_char ch ']' in
|
||||
output_sexp ch b
|
||||
| Arr xs ->
|
||||
output_char ch '(';
|
||||
List.iter (output_sexp ch) xs;
|
||||
output_char ch ')'
|
||||
| Arr xs ->
|
||||
lwt () = write_char ch '(' in
|
||||
lwt () = Lwt_list.iter_s (output_sexp ch) xs in
|
||||
write_char ch ')'
|
||||
|
||||
let rec stream_of_sexp x =
|
||||
Stringstream.make (fun () ->
|
||||
|
@ -58,34 +61,39 @@ let rec stream_of_sexp x =
|
|||
Some ("(", false,
|
||||
Stringstream.seq (Stringstream.map stream_of_sexp xs) (Stringstream.const ")")))
|
||||
|
||||
let output_char_escaped ch c =
|
||||
let write_char_escaped ch c =
|
||||
if c = '\"'
|
||||
then output_string ch "\\\""
|
||||
else output_char ch c
|
||||
then write ch "\\\""
|
||||
else write_char ch c
|
||||
|
||||
let rec output_sexp_human ch x =
|
||||
match x with
|
||||
| Str s ->
|
||||
output_char ch '\"';
|
||||
String.iter (output_char_escaped ch) s;
|
||||
output_char ch '\"'
|
||||
| Hint {hint = h; body = b} ->
|
||||
output_char ch '[';
|
||||
output_sexp_human ch h;
|
||||
output_char ch ']';
|
||||
| Str s ->
|
||||
lwt () = write_char ch '\"' in
|
||||
lwt () = write ch (String.escaped s) in
|
||||
write_char ch '\"'
|
||||
| Hint {hint = h; body = b} ->
|
||||
lwt () = write_char ch '[' in
|
||||
lwt () = output_sexp_human ch h in
|
||||
lwt () = write_char ch ']' in
|
||||
output_sexp_human ch b
|
||||
| Arr xs ->
|
||||
output_char ch '(';
|
||||
(match xs with
|
||||
| [] -> ()
|
||||
| [x] -> output_sexp_human ch x
|
||||
| (x :: xs') ->
|
||||
output_sexp_human ch x;
|
||||
List.iter (fun x -> output_char ch ' '; output_sexp_human ch x) xs');
|
||||
output_char ch ')'
|
||||
| Arr xs ->
|
||||
lwt () = write_char ch '(' in
|
||||
lwt () =
|
||||
(match xs with
|
||||
| [] -> return ()
|
||||
| [x] -> output_sexp_human ch x
|
||||
| (x :: xs') ->
|
||||
lwt () = output_sexp_human ch x in
|
||||
Lwt_list.iter_s
|
||||
(fun x ->
|
||||
lwt () = write_char ch ' ' in
|
||||
output_sexp_human ch x)
|
||||
xs') in
|
||||
write_char ch ')'
|
||||
|
||||
let output_sexp_and_flush ch x =
|
||||
output_sexp ch x;
|
||||
lwt () = output_sexp ch x in
|
||||
flush ch
|
||||
|
||||
let char_numeric c = '0' <= c && c <= '9'
|
||||
|
@ -95,47 +103,50 @@ let digit_val c = (int_of_char c) - (int_of_char '0')
|
|||
|
||||
let input_bytes ch count =
|
||||
let buf = String.create count in (* mutable strings?!?! *)
|
||||
really_input ch buf 0 count;
|
||||
buf
|
||||
lwt () = read_into_exactly ch buf 0 count in
|
||||
return buf
|
||||
|
||||
let syntax_error explanation = raise (Syntax_error explanation)
|
||||
let syntax_error explanation = raise_lwt (Syntax_error explanation)
|
||||
|
||||
let input_sexp_outer input_char input_bytes =
|
||||
let rec input_simple_string len =
|
||||
match input_char () with
|
||||
| ':' -> Str (input_bytes len)
|
||||
| b when char_numeric b -> input_simple_string (len * 10 + digit_val b)
|
||||
| _ -> syntax_error "Bad simple-string length character"
|
||||
match_lwt input_char () with
|
||||
| ':' -> lwt bs = input_bytes len in return (Str bs)
|
||||
| b when char_numeric b -> input_simple_string (len * 10 + digit_val b)
|
||||
| _ -> syntax_error "Bad simple-string length character"
|
||||
in
|
||||
let rec input_sexp_list () =
|
||||
let rec collect acc =
|
||||
match input_sexp_inner () with
|
||||
| None -> Arr (List.rev acc)
|
||||
| Some v -> collect (v :: acc)
|
||||
match_lwt input_sexp_inner () with
|
||||
| None -> return (Arr (List.rev acc))
|
||||
| Some v -> collect (v :: acc)
|
||||
in collect []
|
||||
and input_sexp_inner () =
|
||||
match input_char () with
|
||||
| '(' -> Some (input_sexp_list ())
|
||||
| ')' -> None
|
||||
| '[' ->
|
||||
let hint = input_simple_string 0 in
|
||||
(match input_char () with
|
||||
| ']' -> Some (Hint {hint = hint; body = input_simple_string 0})
|
||||
| _ -> syntax_error "Missing close-bracket in display hint")
|
||||
| b when char_numeric b ->
|
||||
Some (input_simple_string (digit_val b))
|
||||
| b when char_whitespace b ->
|
||||
match_lwt input_char () with
|
||||
| '(' -> lwt xs = input_sexp_list () in return (Some xs)
|
||||
| ')' -> return None
|
||||
| '[' ->
|
||||
lwt hint = input_simple_string 0 in
|
||||
(match_lwt input_char () with
|
||||
| ']' -> lwt b = input_simple_string 0 in return (Some (Hint {hint = hint; body = b}))
|
||||
| _ -> syntax_error "Missing close-bracket in display hint")
|
||||
| b when char_numeric b ->
|
||||
lwt s = input_simple_string (digit_val b) in return (Some s)
|
||||
| b when char_whitespace b ->
|
||||
(* Convenience for testing *)
|
||||
input_sexp_inner ()
|
||||
| _ ->
|
||||
| _ ->
|
||||
syntax_error "Bad SEXP input character"
|
||||
in
|
||||
match input_sexp_inner () with
|
||||
| None -> syntax_error "Unexpected end of list"
|
||||
| Some v -> v
|
||||
match_lwt input_sexp_inner () with
|
||||
| None -> syntax_error "Unexpected end of list"
|
||||
| Some v -> return v
|
||||
|
||||
let input_sexp ch = input_sexp_outer (fun () -> input_char ch) (input_bytes ch)
|
||||
let parse b = input_sexp_outer (fun () -> Ibuffer.next_char b) (Ibuffer.next_chars b)
|
||||
let input_sexp ch = input_sexp_outer (fun () -> read_char ch) (input_bytes ch)
|
||||
let parse b =
|
||||
input_sexp_outer
|
||||
(fun () -> return (Ibuffer.next_char b))
|
||||
(fun count -> return (Ibuffer.next_chars b count))
|
||||
let sexp_of_string s = parse (Ibuffer.of_string s)
|
||||
let string_of_sexp x = Stringstream.to_string (stream_of_sexp x)
|
||||
|
||||
|
|
|
@ -15,6 +15,8 @@
|
|||
(* You should have received a copy of the GNU General Public License *)
|
||||
(* along with Hop. If not, see <http://www.gnu.org/licenses/>. *)
|
||||
|
||||
open Lwt
|
||||
|
||||
type ('success, 'failure) t =
|
||||
| Ok of 'success
|
||||
| Problem of 'failure
|
||||
|
@ -38,9 +40,9 @@ let is_transient x =
|
|||
let is_permanent x = not (is_transient x)
|
||||
|
||||
let replace_ok x info =
|
||||
match x with
|
||||
| Ok _ -> Ok info
|
||||
| Problem p -> Problem p
|
||||
match_lwt x with
|
||||
| Ok _ -> return (Ok info)
|
||||
| Problem p -> return (Problem p)
|
||||
|
||||
let replace_ok' x info_fn =
|
||||
match x with
|
||||
|
|
|
@ -15,6 +15,7 @@
|
|||
(* You should have received a copy of the GNU General Public License *)
|
||||
(* along with Hop. If not, see <http://www.gnu.org/licenses/>. *)
|
||||
|
||||
open Lwt
|
||||
open Datastructures
|
||||
|
||||
type t = {
|
||||
|
@ -42,19 +43,21 @@ let create source subs filter sink_str name reply_sink reply_name =
|
|||
name = name
|
||||
} in
|
||||
subs := StringMap.add uuid sub !subs;
|
||||
Meta.announce_subscription source filter sink_str name true;
|
||||
Node.post_ignore' reply_sink reply_name (Message.subscribe_ok (Sexp.Str uuid)) (Sexp.Str "");
|
||||
sub
|
||||
lwt () = Lwt.join [
|
||||
Meta.announce_subscription source filter sink_str name true;
|
||||
Node.post_ignore' reply_sink reply_name (Message.subscribe_ok (Sexp.Str uuid)) (Sexp.Str "")
|
||||
] in
|
||||
return sub
|
||||
|
||||
let delete source subs uuid =
|
||||
try
|
||||
try_lwt
|
||||
let sub = StringMap.find uuid !subs in
|
||||
sub.live <- false;
|
||||
subs := StringMap.remove uuid !subs;
|
||||
Meta.announce_subscription source sub.filter sub.sink.Node.label sub.name false;
|
||||
Some sub
|
||||
lwt () = Meta.announce_subscription source sub.filter sub.sink.Node.label sub.name false in
|
||||
return (Some sub)
|
||||
with Not_found ->
|
||||
None
|
||||
return None
|
||||
|
||||
let lookup subs uuid =
|
||||
try Some (StringMap.find uuid !subs)
|
||||
|
@ -62,11 +65,11 @@ let lookup subs uuid =
|
|||
|
||||
let send_to_subscription' sub body delete_action =
|
||||
if not sub.live
|
||||
then false
|
||||
then return false
|
||||
else
|
||||
if Node.post sub.sink sub.name body (Sexp.Str sub.uuid)
|
||||
then true
|
||||
else (delete_action sub.uuid; false)
|
||||
match_lwt Node.post sub.sink sub.name body (Sexp.Str sub.uuid) with
|
||||
| true -> return true
|
||||
| false -> (lwt _ = delete_action sub.uuid in return false)
|
||||
|
||||
let send_to_subscription source subs sub body =
|
||||
send_to_subscription' sub body (fun (uuid) -> delete source subs uuid)
|
||||
|
|
|
@ -0,0 +1,198 @@
|
|||
===== 2.3.2 (2011-11-04) =====
|
||||
|
||||
* Add location informations in logs:
|
||||
** allow loggers to get the current location through local storage
|
||||
** pass current location to logging functions
|
||||
** pass the current location with the syntax extension
|
||||
* Add Lwt.on_termination
|
||||
* Add Lwt_unix.reinstall_signal_handler
|
||||
* Add Lwt_io.flush_all
|
||||
* Add assert_lwt keyword to the syntax extension
|
||||
* Add Lwt.wrap
|
||||
* Add Lwt_glib.iter and Lwt_glib.wakeup
|
||||
* ocaml 3.13 ready
|
||||
* Allow to compile without libev support
|
||||
* Fix bugs in Lwt_io
|
||||
* Better handling of forks
|
||||
* Fix many problems on Windows
|
||||
|
||||
===== 2.3.1 (2011-07-13) =====
|
||||
|
||||
* Fix building of documentation when using the tarball
|
||||
* Add Lwt_unix.fsync and Lwt_unix.fdatasync
|
||||
* Fix the stubs for Lwt_unix.send_msg when fd-passing is not
|
||||
available
|
||||
* Add -lwt-sequence-strict option to the syntax extension
|
||||
* Use a custom PRNG state for Lwt.choose and Lwt.pick
|
||||
* Fix a display glitch when starting the toplevel
|
||||
* Add Lwt_unix.fork which should now be used when one want to use
|
||||
Lwt in the child process
|
||||
* Better implementation of Lwt_unix.readlink and
|
||||
Lwt_unix.gethostbyname, which fixes compilation on Hurd
|
||||
* Add Lwt.wakeup_later and Lwt.wakeup_later_exn to be used when one
|
||||
need to do lot of nested wakeup, which fixes a buffer overflow in
|
||||
Lwt_mutex
|
||||
* Fix Lwt_unix.abort and Lwt_unix.close (threads was never wakeup)
|
||||
* Fix Lwt_throttle for correct timings
|
||||
* Fix subtle use of cancel
|
||||
|
||||
===== 2.3.0 (2011-04-12) =====
|
||||
|
||||
* Add an extensible system of engines to:
|
||||
** allow the user to replace libev by another event system, such
|
||||
as select
|
||||
** allow easier integration of external libraries supporting
|
||||
asynchronous operations
|
||||
* Lots of improvements for windows:
|
||||
** use the ocaml select instead of libev by default on windows
|
||||
** make asynchronous operations on non-socket file descriptors
|
||||
such as pipes to work
|
||||
** make glib integration to work
|
||||
* Better use of engines in Lwt_unix: now events are cached to minimize
|
||||
the amount of calls to epoll_ctl
|
||||
* Use an eventfd when possible for notifications for faster delivery
|
||||
* Add modules:
|
||||
** Lwt_sys: allow to test availability of extra features
|
||||
** Lwt_react: replace Lwt_event and Lwt_signal
|
||||
* Allow to configure logging rules at runtime in Lwt_log
|
||||
* Add match_lwt and while_lwt to the syntax extension
|
||||
* Fixes:
|
||||
** syntax extension: handle "lwt ... = ... in ..." at toplevel
|
||||
** make the notification system fork-proof
|
||||
** fix an issue with stubs not raising correctly exceptions
|
||||
|
||||
===== 2.2.1 (2011-01-26) =====
|
||||
|
||||
* Better interaction with Js_of_ocaml.
|
||||
* Add functions {{{Lwt.register_pause_notifier}}} and {{{Lwt.paused_count}}}.
|
||||
|
||||
===== 2.2.0 (2010-12-13) =====
|
||||
|
||||
* Bugfixes:
|
||||
** Fix a bug with cancellable threads causing {{{Canceled}}}
|
||||
exceptions to be raised randomly
|
||||
** Fix a fd-leak in Lwt_io.open_connection
|
||||
* {{{Lwt_unix}}} now use libev instead of select
|
||||
* Add thread local storage support to {{{Lwt}}}
|
||||
* Add backtrace support to {{{Lwt}}}. Now {{{Lwt}}} exceptions can
|
||||
be recored by using the syntax extension with the {{{-lwt-debug}}}
|
||||
command line switch.
|
||||
* Allow blocking system calls to be executed in parallels
|
||||
* Change the type of many functions of {{{Lwt_unix}}}, which now
|
||||
return a {{{Lwt}}} thread
|
||||
* Add functions {{{Lwt_unix.readable}}} and {{{Lwt_unix.writable}}}
|
||||
* Add function {{{Lwt_io.is_busy}}}
|
||||
* Add functions {{{Lwt_event.delay}}} and {{{Lwt_signal.delay}}}
|
||||
* Add function {{{Lwt_term.render_update}}}
|
||||
* Add function {{{Lwt_ssl.embed_socket}}}
|
||||
* Add module {{{Lwt_bytes}}} defining operations on bigarrays
|
||||
instead of strings
|
||||
* Use bigarrays in Lwt_io instead of strings for the internal buffer.
|
||||
Lwt_io.make now takes a function that uses a bigarray.
|
||||
* Add module {{{Lwt_switch}}}
|
||||
|
||||
===== 2.1.1 (2010-06-13) =====
|
||||
|
||||
* Many bugfixes, including:
|
||||
** buggy behaviour of cancellable threads
|
||||
** file descriptor leakage in {{{Lwt_unix.accept_n}}}
|
||||
* Add {{{Lwt.nchoose}}} and {{{Lwt.npick}}}
|
||||
* Use {{{set_close_on_exec}}} for fds created by {{{Lwt_log}}}
|
||||
* Better implementation of lwtized react functions
|
||||
|
||||
===== 2.1.0 (2010-04-19) =====
|
||||
|
||||
* Rename {{{Lwt.select}}} to {{{Lwt.pick}}}
|
||||
* Removing module {{{Lwt_monitor}}} in favour of {{{Lwt_mutex}}} and
|
||||
new module {{{Lwt_condition}}}
|
||||
* More react helpers:
|
||||
** {{{Lwt_event.next}}}
|
||||
** {{{Lwt_event.limit}}} and {{{Lwt_signal.limit}}}
|
||||
** {{{Lwt_event.from}}}
|
||||
* Adding function {{{Lwt_main.fast_yield}}}
|
||||
* Adding unit tests
|
||||
* Optimisation of {{{Lwt}}}
|
||||
* Adding module {{{Lwt_log}}} for logging
|
||||
* Adding a camlp4 filter for remmoving logging statement or inlining
|
||||
tests
|
||||
* Adding module {{{Lwt_daemon}}}
|
||||
* Adding function {{{Lwt_unix.recv_msg}}} and {{{Lwt_unix.send_msg}}}
|
||||
* Adding function {{{Lwt_unix.wait4}}}
|
||||
* Adding function {{{Lwt_io.establish_server}}}
|
||||
* Adding module {{{Lwt_list}}}
|
||||
* Enhancement in {{{Lwt_process}}}, it now support redirections and
|
||||
timeouts
|
||||
* Allow to use {{{select}}} on arbitrary high file descriptors
|
||||
* More commands and features in {{{Lwt_read_line}}}:
|
||||
** Handle "undo" command
|
||||
** New controlable read-lines instances
|
||||
** More edition commands
|
||||
** Completion as you type
|
||||
** Backward search
|
||||
* Enhancement in {{{Lwt_term}}}: more drawing functions and allow to
|
||||
put the terminal into drawing mode
|
||||
* Optimisation of {{{Lwt_stream}}}
|
||||
* Optimisation of {{{Lwt_io.write_char}}} and {{{Lwt_io.read_char}}}
|
||||
* Bugfix of {{{Lwt_stream}}}: two parallel {{{Lwt_stream.get}}}
|
||||
returned the same value
|
||||
* Bugfix in {{{Lwt_unix.connect}}}: it returned immediatly on EINPROGRESS
|
||||
* Bugfixes in {{{Lwt_glib}}}: file descriptors were not monitored correctly
|
||||
|
||||
===== 2.0.0 (2009-10-15) =====
|
||||
|
||||
* Adding modules:
|
||||
** {{{Lwt_stream}}}: lwt-aware version of the {{{Stream}}} module
|
||||
** {{{Lwt_gc}}} for using {{{finalise}}} without
|
||||
{{{Lwt_unix.run}}}
|
||||
** {{{Lwt_io}}}: a new implementation of buffered channels with
|
||||
more features and better handling of concurrent access
|
||||
** {{{Lwt_text}}}: implementation of text channels
|
||||
** {{{Lwt_process}}}: helpers to spawn processes and communicate
|
||||
with them
|
||||
** {{{Lwt_main}}} for abstracting the main loop and allowing
|
||||
replacement by a custom main loop
|
||||
** {{{Lwt_glib}}} for integration into the glib main event loop
|
||||
** {{{Lwt_term}}} for interaction with the terminal
|
||||
** {{{Lwt_read_line}}} for interactive user input
|
||||
** {{{Lwt_monitor}}}, {{{Lwt_mvar}}}: combined locks for
|
||||
synchronization with conditional variables for notification
|
||||
** {{{Lwt_throttle}}} for limiting rate of execution
|
||||
(e.g. for authentication procedure)
|
||||
** {{{Lwt_sequence}}}: mutable sequence of elements
|
||||
** {{{Lwt_event}}}, {{{Lwt_signal}}}: helpers for reactive
|
||||
programming with lwt
|
||||
* Adding a syntax extension {{{pa_lwt}}}:
|
||||
** handles anonymous bind {{{a >> b}}}
|
||||
** adds syntactic sugar for catching errors (ticket #6)
|
||||
** adds syntactic sugar for parallel let-binding construction
|
||||
** adds syntactic sugar for for-like loops
|
||||
* Top-level integration:
|
||||
** threads can runs while reading user input
|
||||
** line editing support
|
||||
* New enhanced OCaml toplevel with some basic completion features
|
||||
* Adding C stubs to reimplement {{{Unix.read}}} and {{{Unix.write}}}
|
||||
with assumption of non-blocking behaviour
|
||||
* Adding more functions/helpers in {{{Lwt}}}
|
||||
* Fixing memory leaks in {{{Lwt.choose}}}
|
||||
* Bugfix in {{{Lwt_chan.close_*}}} (ticket #66)
|
||||
* Separate the type of threads (covariant) from the type of thread
|
||||
wakeners (contravariant); the type of many functions related to
|
||||
{{{Lwt.wait}}} has been changed
|
||||
* Add cancelable threads
|
||||
* Unix-dependent part is now put in its own archive and findlib
|
||||
package.
|
||||
|
||||
===== 1.1.0 (2008-06-25) =====
|
||||
|
||||
* Adding module {{{Lwt_pool}}} for creating pools (for example pools
|
||||
of connections)
|
||||
* Adding a few functions in {{{Lwt_chan}}}
|
||||
* Fixing bugs in {{{Lwt_util.map_serial}}} and
|
||||
{{{Lwt_util.iter_serial}}}
|
||||
* Putting {{{Lwt_preemptive}}}, {{{Lwt_lib}}} and {{{Lwt_ssl}}} in
|
||||
separate libraries and findlib subpackages so that lwt.cma depends
|
||||
only on unix.cma.
|
||||
|
||||
===== 1.0.0 (and before) =====
|
||||
|
||||
* See Ocsigen changelog
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,552 @@
|
|||
This program is released under the LGPL version 2.1 (see the text below) with
|
||||
the additional exemption that compiling, linking, and/or using OpenSSL is
|
||||
allowed.
|
||||
|
||||
As a special exception to the GNU Library General Public License, you
|
||||
may also link, statically or dynamically, a "work that uses the Library"
|
||||
with a publicly distributed version of the Library to produce an
|
||||
executable file containing portions of the Library, and distribute
|
||||
that executable file under terms of your choice, without any of the
|
||||
additional requirements listed in clause 6 of the GNU Library General
|
||||
Public License. By "a publicly distributed version of the Library",
|
||||
we mean either the unmodified Library, or a
|
||||
modified version of the Library that is distributed under the
|
||||
conditions defined in clause 3 of the GNU Library General Public
|
||||
License. This exception does not however invalidate any other reasons
|
||||
why the executable file might be covered by the GNU Library General
|
||||
Public License.
|
||||
|
||||
Some parts, when stated (as licenced under BSD3) are licenced under
|
||||
3-clauses or Modified BSD License.
|
||||
|
||||
|
||||
GNU LESSER GENERAL PUBLIC LICENSE
|
||||
Version 2.1, February 1999
|
||||
|
||||
Copyright (C) 1991, 1999 Free Software Foundation, Inc.
|
||||
51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
|
||||
Everyone is permitted to copy and distribute verbatim copies
|
||||
of this license document, but changing it is not allowed.
|
||||
|
||||
[This is the first released version of the Lesser GPL. It also counts
|
||||
as the successor of the GNU Library Public License, version 2, hence
|
||||
the version number 2.1.]
|
||||
|
||||
Preamble
|
||||
|
||||
The licenses for most software are designed to take away your
|
||||
freedom to share and change it. By contrast, the GNU General Public
|
||||
Licenses are intended to guarantee your freedom to share and change
|
||||
free software--to make sure the software is free for all its users.
|
||||
|
||||
This license, the Lesser General Public License, applies to some
|
||||
specially designated software packages--typically libraries--of the
|
||||
Free Software Foundation and other authors who decide to use it. You
|
||||
can use it too, but we suggest you first think carefully about whether
|
||||
this license or the ordinary General Public License is the better
|
||||
strategy to use in any particular case, based on the explanations below.
|
||||
|
||||
When we speak of free software, we are referring to freedom of use,
|
||||
not price. Our General Public Licenses are designed to make sure that
|
||||
you have the freedom to distribute copies of free software (and charge
|
||||
for this service if you wish); that you receive source code or can get
|
||||
it if you want it; that you can change the software and use pieces of
|
||||
it in new free programs; and that you are informed that you can do
|
||||
these things.
|
||||
|
||||
To protect your rights, we need to make restrictions that forbid
|
||||
distributors to deny you these rights or to ask you to surrender these
|
||||
rights. These restrictions translate to certain responsibilities for
|
||||
you if you distribute copies of the library or if you modify it.
|
||||
|
||||
For example, if you distribute copies of the library, whether gratis
|
||||
or for a fee, you must give the recipients all the rights that we gave
|
||||
you. You must make sure that they, too, receive or can get the source
|
||||
code. If you link other code with the library, you must provide
|
||||
complete object files to the recipients, so that they can relink them
|
||||
with the library after making changes to the library and recompiling
|
||||
it. And you must show them these terms so they know their rights.
|
||||
|
||||
We protect your rights with a two-step method: (1) we copyright the
|
||||
library, and (2) we offer you this license, which gives you legal
|
||||
permission to copy, distribute and/or modify the library.
|
||||
|
||||
To protect each distributor, we want to make it very clear that
|
||||
there is no warranty for the free library. Also, if the library is
|
||||
modified by someone else and passed on, the recipients should know
|
||||
that what they have is not the original version, so that the original
|
||||
author's reputation will not be affected by problems that might be
|
||||
introduced by others.
|
||||
|
||||
Finally, software patents pose a constant threat to the existence of
|
||||
any free program. We wish to make sure that a company cannot
|
||||
effectively restrict the users of a free program by obtaining a
|
||||
restrictive license from a patent holder. Therefore, we insist that
|
||||
any patent license obtained for a version of the library must be
|
||||
consistent with the full freedom of use specified in this license.
|
||||
|
||||
Most GNU software, including some libraries, is covered by the
|
||||
ordinary GNU General Public License. This license, the GNU Lesser
|
||||
General Public License, applies to certain designated libraries, and
|
||||
is quite different from the ordinary General Public License. We use
|
||||
this license for certain libraries in order to permit linking those
|
||||
libraries into non-free programs.
|
||||
|
||||
When a program is linked with a library, whether statically or using
|
||||
a shared library, the combination of the two is legally speaking a
|
||||
combined work, a derivative of the original library. The ordinary
|
||||
General Public License therefore permits such linking only if the
|
||||
entire combination fits its criteria of freedom. The Lesser General
|
||||
Public License permits more lax criteria for linking other code with
|
||||
the library.
|
||||
|
||||
We call this license the "Lesser" General Public License because it
|
||||
does Less to protect the user's freedom than the ordinary General
|
||||
Public License. It also provides other free software developers Less
|
||||
of an advantage over competing non-free programs. These disadvantages
|
||||
are the reason we use the ordinary General Public License for many
|
||||
libraries. However, the Lesser license provides advantages in certain
|
||||
special circumstances.
|
||||
|
||||
For example, on rare occasions, there may be a special need to
|
||||
encourage the widest possible use of a certain library, so that it becomes
|
||||
a de-facto standard. To achieve this, non-free programs must be
|
||||
allowed to use the library. A more frequent case is that a free
|
||||
library does the same job as widely used non-free libraries. In this
|
||||
case, there is little to gain by limiting the free library to free
|
||||
software only, so we use the Lesser General Public License.
|
||||
|
||||
In other cases, permission to use a particular library in non-free
|
||||
programs enables a greater number of people to use a large body of
|
||||
free software. For example, permission to use the GNU C Library in
|
||||
non-free programs enables many more people to use the whole GNU
|
||||
operating system, as well as its variant, the GNU/Linux operating
|
||||
system.
|
||||
|
||||
Although the Lesser General Public License is Less protective of the
|
||||
users' freedom, it does ensure that the user of a program that is
|
||||
linked with the Library has the freedom and the wherewithal to run
|
||||
that program using a modified version of the Library.
|
||||
|
||||
The precise terms and conditions for copying, distribution and
|
||||
modification follow. Pay close attention to the difference between a
|
||||
"work based on the library" and a "work that uses the library". The
|
||||
former contains code derived from the library, whereas the latter must
|
||||
be combined with the library in order to run.
|
||||
|
||||
GNU LESSER GENERAL PUBLIC LICENSE
|
||||
TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
|
||||
|
||||
0. This License Agreement applies to any software library or other
|
||||
program which contains a notice placed by the copyright holder or
|
||||
other authorized party saying it may be distributed under the terms of
|
||||
this Lesser General Public License (also called "this License").
|
||||
Each licensee is addressed as "you".
|
||||
|
||||
A "library" means a collection of software functions and/or data
|
||||
prepared so as to be conveniently linked with application programs
|
||||
(which use some of those functions and data) to form executables.
|
||||
|
||||
The "Library", below, refers to any such software library or work
|
||||
which has been distributed under these terms. A "work based on the
|
||||
Library" means either the Library or any derivative work under
|
||||
copyright law: that is to say, a work containing the Library or a
|
||||
portion of it, either verbatim or with modifications and/or translated
|
||||
straightforwardly into another language. (Hereinafter, translation is
|
||||
included without limitation in the term "modification".)
|
||||
|
||||
"Source code" for a work means the preferred form of the work for
|
||||
making modifications to it. For a library, complete source code means
|
||||
all the source code for all modules it contains, plus any associated
|
||||
interface definition files, plus the scripts used to control compilation
|
||||
and installation of the library.
|
||||
|
||||
Activities other than copying, distribution and modification are not
|
||||
covered by this License; they are outside its scope. The act of
|
||||
running a program using the Library is not restricted, and output from
|
||||
such a program is covered only if its contents constitute a work based
|
||||
on the Library (independent of the use of the Library in a tool for
|
||||
writing it). Whether that is true depends on what the Library does
|
||||
and what the program that uses the Library does.
|
||||
|
||||
1. You may copy and distribute verbatim copies of the Library's
|
||||
complete source code as you receive it, in any medium, provided that
|
||||
you conspicuously and appropriately publish on each copy an
|
||||
appropriate copyright notice and disclaimer of warranty; keep intact
|
||||
all the notices that refer to this License and to the absence of any
|
||||
warranty; and distribute a copy of this License along with the
|
||||
Library.
|
||||
|
||||
You may charge a fee for the physical act of transferring a copy,
|
||||
and you may at your option offer warranty protection in exchange for a
|
||||
fee.
|
||||
|
||||
2. You may modify your copy or copies of the Library or any portion
|
||||
of it, thus forming a work based on the Library, and copy and
|
||||
distribute such modifications or work under the terms of Section 1
|
||||
above, provided that you also meet all of these conditions:
|
||||
|
||||
a) The modified work must itself be a software library.
|
||||
|
||||
b) You must cause the files modified to carry prominent notices
|
||||
stating that you changed the files and the date of any change.
|
||||
|
||||
c) You must cause the whole of the work to be licensed at no
|
||||
charge to all third parties under the terms of this License.
|
||||
|
||||
d) If a facility in the modified Library refers to a function or a
|
||||
table of data to be supplied by an application program that uses
|
||||
the facility, other than as an argument passed when the facility
|
||||
is invoked, then you must make a good faith effort to ensure that,
|
||||
in the event an application does not supply such function or
|
||||
table, the facility still operates, and performs whatever part of
|
||||
its purpose remains meaningful.
|
||||
|
||||
(For example, a function in a library to compute square roots has
|
||||
a purpose that is entirely well-defined independent of the
|
||||
application. Therefore, Subsection 2d requires that any
|
||||
application-supplied function or table used by this function must
|
||||
be optional: if the application does not supply it, the square
|
||||
root function must still compute square roots.)
|
||||
|
||||
These requirements apply to the modified work as a whole. If
|
||||
identifiable sections of that work are not derived from the Library,
|
||||
and can be reasonably considered independent and separate works in
|
||||
themselves, then this License, and its terms, do not apply to those
|
||||
sections when you distribute them as separate works. But when you
|
||||
distribute the same sections as part of a whole which is a work based
|
||||
on the Library, the distribution of the whole must be on the terms of
|
||||
this License, whose permissions for other licensees extend to the
|
||||
entire whole, and thus to each and every part regardless of who wrote
|
||||
it.
|
||||
|
||||
Thus, it is not the intent of this section to claim rights or contest
|
||||
your rights to work written entirely by you; rather, the intent is to
|
||||
exercise the right to control the distribution of derivative or
|
||||
collective works based on the Library.
|
||||
|
||||
In addition, mere aggregation of another work not based on the Library
|
||||
with the Library (or with a work based on the Library) on a volume of
|
||||
a storage or distribution medium does not bring the other work under
|
||||
the scope of this License.
|
||||
|
||||
3. You may opt to apply the terms of the ordinary GNU General Public
|
||||
License instead of this License to a given copy of the Library. To do
|
||||
this, you must alter all the notices that refer to this License, so
|
||||
that they refer to the ordinary GNU General Public License, version 2,
|
||||
instead of to this License. (If a newer version than version 2 of the
|
||||
ordinary GNU General Public License has appeared, then you can specify
|
||||
that version instead if you wish.) Do not make any other change in
|
||||
these notices.
|
||||
|
||||
Once this change is made in a given copy, it is irreversible for
|
||||
that copy, so the ordinary GNU General Public License applies to all
|
||||
subsequent copies and derivative works made from that copy.
|
||||
|
||||
This option is useful when you wish to copy part of the code of
|
||||
the Library into a program that is not a library.
|
||||
|
||||
4. You may copy and distribute the Library (or a portion or
|
||||
derivative of it, under Section 2) in object code or executable form
|
||||
under the terms of Sections 1 and 2 above provided that you accompany
|
||||
it with the complete corresponding machine-readable source code, which
|
||||
must be distributed under the terms of Sections 1 and 2 above on a
|
||||
medium customarily used for software interchange.
|
||||
|
||||
If distribution of object code is made by offering access to copy
|
||||
from a designated place, then offering equivalent access to copy the
|
||||
source code from the same place satisfies the requirement to
|
||||
distribute the source code, even though third parties are not
|
||||
compelled to copy the source along with the object code.
|
||||
|
||||
5. A program that contains no derivative of any portion of the
|
||||
Library, but is designed to work with the Library by being compiled or
|
||||
linked with it, is called a "work that uses the Library". Such a
|
||||
work, in isolation, is not a derivative work of the Library, and
|
||||
therefore falls outside the scope of this License.
|
||||
|
||||
However, linking a "work that uses the Library" with the Library
|
||||
creates an executable that is a derivative of the Library (because it
|
||||
contains portions of the Library), rather than a "work that uses the
|
||||
library". The executable is therefore covered by this License.
|
||||
Section 6 states terms for distribution of such executables.
|
||||
|
||||
When a "work that uses the Library" uses material from a header file
|
||||
that is part of the Library, the object code for the work may be a
|
||||
derivative work of the Library even though the source code is not.
|
||||
Whether this is true is especially significant if the work can be
|
||||
linked without the Library, or if the work is itself a library. The
|
||||
threshold for this to be true is not precisely defined by law.
|
||||
|
||||
If such an object file uses only numerical parameters, data
|
||||
structure layouts and accessors, and small macros and small inline
|
||||
functions (ten lines or less in length), then the use of the object
|
||||
file is unrestricted, regardless of whether it is legally a derivative
|
||||
work. (Executables containing this object code plus portions of the
|
||||
Library will still fall under Section 6.)
|
||||
|
||||
Otherwise, if the work is a derivative of the Library, you may
|
||||
distribute the object code for the work under the terms of Section 6.
|
||||
Any executables containing that work also fall under Section 6,
|
||||
whether or not they are linked directly with the Library itself.
|
||||
|
||||
6. As an exception to the Sections above, you may also combine or
|
||||
link a "work that uses the Library" with the Library to produce a
|
||||
work containing portions of the Library, and distribute that work
|
||||
under terms of your choice, provided that the terms permit
|
||||
modification of the work for the customer's own use and reverse
|
||||
engineering for debugging such modifications.
|
||||
|
||||
You must give prominent notice with each copy of the work that the
|
||||
Library is used in it and that the Library and its use are covered by
|
||||
this License. You must supply a copy of this License. If the work
|
||||
during execution displays copyright notices, you must include the
|
||||
copyright notice for the Library among them, as well as a reference
|
||||
directing the user to the copy of this License. Also, you must do one
|
||||
of these things:
|
||||
|
||||
a) Accompany the work with the complete corresponding
|
||||
machine-readable source code for the Library including whatever
|
||||
changes were used in the work (which must be distributed under
|
||||
Sections 1 and 2 above); and, if the work is an executable linked
|
||||
with the Library, with the complete machine-readable "work that
|
||||
uses the Library", as object code and/or source code, so that the
|
||||
user can modify the Library and then relink to produce a modified
|
||||
executable containing the modified Library. (It is understood
|
||||
that the user who changes the contents of definitions files in the
|
||||
Library will not necessarily be able to recompile the application
|
||||
to use the modified definitions.)
|
||||
|
||||
b) Use a suitable shared library mechanism for linking with the
|
||||
Library. A suitable mechanism is one that (1) uses at run time a
|
||||
copy of the library already present on the user's computer system,
|
||||
rather than copying library functions into the executable, and (2)
|
||||
will operate properly with a modified version of the library, if
|
||||
the user installs one, as long as the modified version is
|
||||
interface-compatible with the version that the work was made with.
|
||||
|
||||
c) Accompany the work with a written offer, valid for at
|
||||
least three years, to give the same user the materials
|
||||
specified in Subsection 6a, above, for a charge no more
|
||||
than the cost of performing this distribution.
|
||||
|
||||
d) If distribution of the work is made by offering access to copy
|
||||
from a designated place, offer equivalent access to copy the above
|
||||
specified materials from the same place.
|
||||
|
||||
e) Verify that the user has already received a copy of these
|
||||
materials or that you have already sent this user a copy.
|
||||
|
||||
For an executable, the required form of the "work that uses the
|
||||
Library" must include any data and utility programs needed for
|
||||
reproducing the executable from it. However, as a special exception,
|
||||
the materials to be distributed need not include anything that is
|
||||
normally distributed (in either source or binary form) with the major
|
||||
components (compiler, kernel, and so on) of the operating system on
|
||||
which the executable runs, unless that component itself accompanies
|
||||
the executable.
|
||||
|
||||
It may happen that this requirement contradicts the license
|
||||
restrictions of other proprietary libraries that do not normally
|
||||
accompany the operating system. Such a contradiction means you cannot
|
||||
use both them and the Library together in an executable that you
|
||||
distribute.
|
||||
|
||||
7. You may place library facilities that are a work based on the
|
||||
Library side-by-side in a single library together with other library
|
||||
facilities not covered by this License, and distribute such a combined
|
||||
library, provided that the separate distribution of the work based on
|
||||
the Library and of the other library facilities is otherwise
|
||||
permitted, and provided that you do these two things:
|
||||
|
||||
a) Accompany the combined library with a copy of the same work
|
||||
based on the Library, uncombined with any other library
|
||||
facilities. This must be distributed under the terms of the
|
||||
Sections above.
|
||||
|
||||
b) Give prominent notice with the combined library of the fact
|
||||
that part of it is a work based on the Library, and explaining
|
||||
where to find the accompanying uncombined form of the same work.
|
||||
|
||||
8. You may not copy, modify, sublicense, link with, or distribute
|
||||
the Library except as expressly provided under this License. Any
|
||||
attempt otherwise to copy, modify, sublicense, link with, or
|
||||
distribute the Library is void, and will automatically terminate your
|
||||
rights under this License. However, parties who have received copies,
|
||||
or rights, from you under this License will not have their licenses
|
||||
terminated so long as such parties remain in full compliance.
|
||||
|
||||
9. You are not required to accept this License, since you have not
|
||||
signed it. However, nothing else grants you permission to modify or
|
||||
distribute the Library or its derivative works. These actions are
|
||||
prohibited by law if you do not accept this License. Therefore, by
|
||||
modifying or distributing the Library (or any work based on the
|
||||
Library), you indicate your acceptance of this License to do so, and
|
||||
all its terms and conditions for copying, distributing or modifying
|
||||
the Library or works based on it.
|
||||
|
||||
10. Each time you redistribute the Library (or any work based on the
|
||||
Library), the recipient automatically receives a license from the
|
||||
original licensor to copy, distribute, link with or modify the Library
|
||||
subject to these terms and conditions. You may not impose any further
|
||||
restrictions on the recipients' exercise of the rights granted herein.
|
||||
You are not responsible for enforcing compliance by third parties with
|
||||
this License.
|
||||
|
||||
11. If, as a consequence of a court judgment or allegation of patent
|
||||
infringement or for any other reason (not limited to patent issues),
|
||||
conditions are imposed on you (whether by court order, agreement or
|
||||
otherwise) that contradict the conditions of this License, they do not
|
||||
excuse you from the conditions of this License. If you cannot
|
||||
distribute so as to satisfy simultaneously your obligations under this
|
||||
License and any other pertinent obligations, then as a consequence you
|
||||
may not distribute the Library at all. For example, if a patent
|
||||
license would not permit royalty-free redistribution of the Library by
|
||||
all those who receive copies directly or indirectly through you, then
|
||||
the only way you could satisfy both it and this License would be to
|
||||
refrain entirely from distribution of the Library.
|
||||
|
||||
If any portion of this section is held invalid or unenforceable under any
|
||||
particular circumstance, the balance of the section is intended to apply,
|
||||
and the section as a whole is intended to apply in other circumstances.
|
||||
|
||||
It is not the purpose of this section to induce you to infringe any
|
||||
patents or other property right claims or to contest validity of any
|
||||
such claims; this section has the sole purpose of protecting the
|
||||
integrity of the free software distribution system which is
|
||||
implemented by public license practices. Many people have made
|
||||
generous contributions to the wide range of software distributed
|
||||
through that system in reliance on consistent application of that
|
||||
system; it is up to the author/donor to decide if he or she is willing
|
||||
to distribute software through any other system and a licensee cannot
|
||||
impose that choice.
|
||||
|
||||
This section is intended to make thoroughly clear what is believed to
|
||||
be a consequence of the rest of this License.
|
||||
|
||||
12. If the distribution and/or use of the Library is restricted in
|
||||
certain countries either by patents or by copyrighted interfaces, the
|
||||
original copyright holder who places the Library under this License may add
|
||||
an explicit geographical distribution limitation excluding those countries,
|
||||
so that distribution is permitted only in or among countries not thus
|
||||
excluded. In such case, this License incorporates the limitation as if
|
||||
written in the body of this License.
|
||||
|
||||
13. The Free Software Foundation may publish revised and/or new
|
||||
versions of the Lesser General Public License from time to time.
|
||||
Such new versions will be similar in spirit to the present version,
|
||||
but may differ in detail to address new problems or concerns.
|
||||
|
||||
Each version is given a distinguishing version number. If the Library
|
||||
specifies a version number of this License which applies to it and
|
||||
"any later version", you have the option of following the terms and
|
||||
conditions either of that version or of any later version published by
|
||||
the Free Software Foundation. If the Library does not specify a
|
||||
license version number, you may choose any version ever published by
|
||||
the Free Software Foundation.
|
||||
|
||||
14. If you wish to incorporate parts of the Library into other free
|
||||
programs whose distribution conditions are incompatible with these,
|
||||
write to the author to ask for permission. For software which is
|
||||
copyrighted by the Free Software Foundation, write to the Free
|
||||
Software Foundation; we sometimes make exceptions for this. Our
|
||||
decision will be guided by the two goals of preserving the free status
|
||||
of all derivatives of our free software and of promoting the sharing
|
||||
and reuse of software generally.
|
||||
|
||||
NO WARRANTY
|
||||
|
||||
15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO
|
||||
WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.
|
||||
EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
|
||||
OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY
|
||||
KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
|
||||
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
|
||||
LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME
|
||||
THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
|
||||
|
||||
16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN
|
||||
WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY
|
||||
AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU
|
||||
FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR
|
||||
CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
|
||||
LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
|
||||
RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
|
||||
FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
|
||||
SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
|
||||
DAMAGES.
|
||||
|
||||
END OF TERMS AND CONDITIONS
|
||||
|
||||
How to Apply These Terms to Your New Libraries
|
||||
|
||||
If you develop a new library, and you want it to be of the greatest
|
||||
possible use to the public, we recommend making it free software that
|
||||
everyone can redistribute and change. You can do so by permitting
|
||||
redistribution under these terms (or, alternatively, under the terms of the
|
||||
ordinary General Public License).
|
||||
|
||||
To apply these terms, attach the following notices to the library. It is
|
||||
safest to attach them to the start of each source file to most effectively
|
||||
convey the exclusion of warranty; and each file should have at least the
|
||||
"copyright" line and a pointer to where the full notice is found.
|
||||
|
||||
<one line to give the library's name and a brief idea of what it does.>
|
||||
Copyright (C) <year> <name of author>
|
||||
|
||||
This library is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU Lesser General Public
|
||||
License as published by the Free Software Foundation; either
|
||||
version 2.1 of the License, or (at your option) any later version.
|
||||
|
||||
This library is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
Lesser General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
|
||||
|
||||
Also add information on how to contact you by electronic and paper mail.
|
||||
|
||||
You should also get your employer (if you work as a programmer) or your
|
||||
school, if any, to sign a "copyright disclaimer" for the library, if
|
||||
necessary. Here is a sample; alter the names:
|
||||
|
||||
Yoyodyne, Inc., hereby disclaims all copyright interest in the
|
||||
library `Frob' (a library for tweaking knobs) written by James Random Hacker.
|
||||
|
||||
<signature of Ty Coon>, 1 April 1990
|
||||
Ty Coon, President of Vice
|
||||
|
||||
That's all there is to it!
|
||||
|
||||
|
||||
====== BSD3 or Modified BSD License ======
|
||||
|
||||
Copyright (c) <year>, <copyright holder>
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
* Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
* Redistributions in binary form must reproduce the above copyright
|
||||
notice, this list of conditions and the following disclaimer in the
|
||||
documentation and/or other materials provided with the distribution.
|
||||
* Neither the name of the <organization> nor the
|
||||
names of its contributors may be used to endorse or promote products
|
||||
derived from this software without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
|
||||
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
||||
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
|
||||
DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY
|
||||
DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
|
||||
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
|
||||
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
|
||||
ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
|
||||
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
@ -0,0 +1,4 @@
|
|||
The Ocsigen application core, and other portions of the official Ocsigen
|
||||
distribution not explicitly licensed otherwise, are licensed under
|
||||
the GNU LESSER GENERAL PUBLIC LICENSE with openssl linking exception
|
||||
-- see the 'COPYING' file in this directory for details.
|
|
@ -0,0 +1,38 @@
|
|||
# OASIS_START
|
||||
# DO NOT EDIT (digest: bc1e05bfc8b39b664f29dae8dbd3ebbb)
|
||||
|
||||
SETUP = ocaml setup.ml
|
||||
|
||||
build: setup.data
|
||||
$(SETUP) -build $(BUILDFLAGS)
|
||||
|
||||
doc: setup.data build
|
||||
$(SETUP) -doc $(DOCFLAGS)
|
||||
|
||||
test: setup.data build
|
||||
$(SETUP) -test $(TESTFLAGS)
|
||||
|
||||
all:
|
||||
$(SETUP) -all $(ALLFLAGS)
|
||||
|
||||
install: setup.data
|
||||
$(SETUP) -install $(INSTALLFLAGS)
|
||||
|
||||
uninstall: setup.data
|
||||
$(SETUP) -uninstall $(UNINSTALLFLAGS)
|
||||
|
||||
reinstall: setup.data
|
||||
$(SETUP) -reinstall $(REINSTALLFLAGS)
|
||||
|
||||
clean:
|
||||
$(SETUP) -clean $(CLEANFLAGS)
|
||||
|
||||
distclean:
|
||||
$(SETUP) -distclean $(DISTCLEANFLAGS)
|
||||
|
||||
setup.data:
|
||||
$(SETUP) -configure $(CONFIGUREFLAGS)
|
||||
|
||||
.PHONY: build doc test all install uninstall reinstall clean distclean configure
|
||||
|
||||
# OASIS_STOP
|
|
@ -0,0 +1,74 @@
|
|||
Lwt: lightweight thread library for Objective Caml
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
|
||||
This library is part of the Ocsigen project. See:
|
||||
|
||||
http://ocsigen.org/lwt
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
|
||||
Requirements:
|
||||
|
||||
* ocaml with ocamlbuild (>= 3.11.0)
|
||||
* findlib
|
||||
* react (from http://erratique.ch/software/react)
|
||||
* [optionnal] libev (from http://software.schmorp.de/pkg/libev.html)
|
||||
* [optionnal] ocaml-text (needed for the enhanced toplevel)
|
||||
* [optionnal] ocamlssl (>= 0.4.0) (ocamlssl needs openssl) (>= 0.4.1 for MacOS)
|
||||
* [optionnal] glib-2.0 developpement files and pkg-config
|
||||
|
||||
If ocaml/findlib/ocamlssl... are not installed on your computer, you
|
||||
can use GODI to install them automatically. See:
|
||||
|
||||
http://godi.camlcity.org/godi/index.html
|
||||
|
||||
They might also be available through your distribution.
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
|
||||
Instructions:
|
||||
|
||||
* run "ocaml setup.ml -configure" to configure sources
|
||||
You can add '--enable-<lib>' to enable compilation of
|
||||
the sub-library <lib>. The flag '--enable-all' will
|
||||
enable everything.
|
||||
In order to compile without libev support you must add
|
||||
'--disable-libev'.
|
||||
* run "ocaml setup.ml -build" to compile
|
||||
* run "ocaml setup.ml -install" as root to install compiled libraries
|
||||
* run "ocaml setup.ml -uninstall" as root to uninstall them
|
||||
|
||||
HTML documentation is generated in _build/lwt.docdir/, but is not
|
||||
installed by default.
|
||||
|
||||
If you get the development version you need to obtain oasis
|
||||
(http://oasis.forge.ocamlcore.org/).
|
||||
|
||||
If you want to build the toplevel you have to install compiler
|
||||
libraries, under debian it is the package
|
||||
ocaml-compiler-libs. Otherwise you can add a symlink like that:
|
||||
|
||||
$ ln -s <ocaml sources> $(ocamlc -where)/compiler-libs
|
||||
|
||||
Note that the utop project replaces the Lwt toplevel:
|
||||
|
||||
https://forge.ocamlcore.org/projects/utop/
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
|
||||
Authors:
|
||||
|
||||
* Jérôme Vouillon
|
||||
* Vincent Balat
|
||||
* Nataliya Guts
|
||||
* Pierre Clairambault
|
||||
* Stéphane Glondu
|
||||
* Jérémie Dimino
|
||||
* Warren Harris (Metaweb Technologies, Inc.)
|
||||
* Pierre Chambart
|
||||
* Mauricio Fernandez
|
||||
|
||||
See each source file for copyright information, and COPYING for license.
|
||||
|
||||
--------------------------------------------------------------------------
|
|
@ -0,0 +1,383 @@
|
|||
# +-------------------------------------------------------------------+
|
||||
# | Package parameters |
|
||||
# +-------------------------------------------------------------------+
|
||||
|
||||
OASISFormat: 0.1
|
||||
OCamlVersion: >= 3.12
|
||||
Name: lwt
|
||||
Version: 2.3.2
|
||||
LicenseFile: COPYING
|
||||
License: LGPL-2.1 with OCaml linking exception
|
||||
Authors:
|
||||
Jérôme Vouillon,
|
||||
Vincent Balat,
|
||||
Nataliya Guts,
|
||||
Pierre Clairambault,
|
||||
Stéphane Glondu,
|
||||
Jérémie Dimino,
|
||||
Warren Harris,
|
||||
Pierre Chambart,
|
||||
Mauricio Fernandez
|
||||
Homepage: http://ocsigen.org/lwt/
|
||||
BuildTools: ocamlbuild
|
||||
Plugins: DevFiles (0.2), META (0.2)
|
||||
PostConfCommand: ocaml discover.ml -ocamlc $ocamlc -ext-obj $ext_obj -exec-name $default_executable_name -use-libev $libev -os-type $os_type
|
||||
PostDistCleanCommand: $rm src/unix/lwt_config.h src/unix/lwt_config.ml
|
||||
|
||||
Synopsis: Lightweight thread library for Objective Caml
|
||||
Description:
|
||||
Lwt is a library of cooperative threads implemented in monadic
|
||||
style. With respect to preemptive threads, cooperative threads are
|
||||
not using a scheduler to distribute processor time between
|
||||
threads. Instead of this, each thread must tell the others that he
|
||||
wants to let them work.
|
||||
|
||||
# +-------------------------------------------------------------------+
|
||||
# | Flags |
|
||||
# +-------------------------------------------------------------------+
|
||||
|
||||
Flag all
|
||||
Description: build and install everything
|
||||
Default: false
|
||||
|
||||
Flag unix
|
||||
Description: Unix support
|
||||
Default: true
|
||||
|
||||
Flag react
|
||||
Description: React helpers
|
||||
Default: false
|
||||
|
||||
Flag glib
|
||||
Description: Glib integration
|
||||
Default: false
|
||||
|
||||
Flag ssl
|
||||
Description: SSL support
|
||||
Default: false
|
||||
|
||||
Flag text
|
||||
Description: Text mode utilities
|
||||
Default: false
|
||||
|
||||
Flag preemptive
|
||||
Description: Preemptive threads support
|
||||
Default: true
|
||||
|
||||
Flag extra
|
||||
Description: Asynchronous unix functions
|
||||
Default: true
|
||||
|
||||
Flag toplevel
|
||||
Description: Enhanced toplevel
|
||||
Default: false
|
||||
|
||||
Flag libev
|
||||
Description: Compile with libev support
|
||||
Default$: !os_type(Win32)
|
||||
|
||||
# +-------------------------------------------------------------------+
|
||||
# | Libraries |
|
||||
# +-------------------------------------------------------------------+
|
||||
|
||||
Library "optcomp"
|
||||
Install: false
|
||||
Path: syntax
|
||||
Modules: Pa_optcomp
|
||||
BuildDepends: camlp4.lib, camlp4.quotations.o
|
||||
|
||||
Library "lwt"
|
||||
Path: src/core
|
||||
Modules:
|
||||
Lwt_condition,
|
||||
Lwt_list,
|
||||
Lwt,
|
||||
Lwt_mutex,
|
||||
Lwt_mvar,
|
||||
Lwt_pool,
|
||||
Lwt_sequence,
|
||||
Lwt_stream,
|
||||
Lwt_switch,
|
||||
Lwt_util,
|
||||
Lwt_pqueue
|
||||
XMETADescription: Lightweight thread library for OCaml (core library)
|
||||
|
||||
Library "lwt-unix"
|
||||
Build$: flag(unix) || flag(all)
|
||||
Install$: flag(unix) || flag(all)
|
||||
FindlibName: unix
|
||||
FindlibParent: lwt
|
||||
Path: src/unix
|
||||
Modules:
|
||||
Lwt_chan,
|
||||
Lwt_daemon,
|
||||
Lwt_gc,
|
||||
Lwt_io,
|
||||
Lwt_log,
|
||||
Lwt_main,
|
||||
Lwt_process,
|
||||
Lwt_throttle,
|
||||
Lwt_timeout,
|
||||
Lwt_unix,
|
||||
Lwt_sys,
|
||||
Lwt_engine,
|
||||
Lwt_bytes
|
||||
InternalModules:
|
||||
Lwt_log_rules
|
||||
BuildDepends: lwt, unix, bigarray
|
||||
XMETADescription: Unix support for lwt
|
||||
CSources:
|
||||
lwt_config.h,
|
||||
lwt_unix.h,
|
||||
lwt_unix_stubs.c,
|
||||
lwt_libev_stubs.c
|
||||
if os_type(Win32)
|
||||
CCLib+: ws2_32.lib
|
||||
else
|
||||
CCLib+: -lpthread
|
||||
if flag(libev)
|
||||
CCLib+: -lev
|
||||
|
||||
Library "lwt-simple-top"
|
||||
Build$: flag(unix) || flag(all)
|
||||
Install$: flag(unix) || flag(all)
|
||||
FindlibName: simple-top
|
||||
FindlibParent: lwt
|
||||
Path: src/simple_top
|
||||
InternalModules: Lwt_simple_top
|
||||
BuildDepends: lwt, lwt.unix
|
||||
XMETADescription: Unix support for lwt
|
||||
|
||||
Library "lwt-react"
|
||||
Build$: flag(react) || flag(all)
|
||||
Install$: flag(react) || flag(all)
|
||||
FindlibName: react
|
||||
FindlibParent: lwt
|
||||
Path: src/react
|
||||
Modules: Lwt_event, Lwt_signal, Lwt_react
|
||||
BuildDepends: lwt, react
|
||||
XMETADescription: Reactive programming helpers
|
||||
|
||||
Library "lwt-preemptive"
|
||||
Build$: flag(preemptive) || flag(all)
|
||||
Install$: flag(preemptive) || flag(all)
|
||||
FindlibName: preemptive
|
||||
FindlibParent: lwt
|
||||
Path: src/preemptive
|
||||
Modules: Lwt_preemptive
|
||||
BuildDepends: lwt, lwt.unix, threads
|
||||
XMETADescription: Preemptive threads support for Lwt
|
||||
|
||||
Library "lwt-extra"
|
||||
Build$: flag(extra) || flag(all)
|
||||
Install$: flag(extra) || flag(all)
|
||||
FindlibName: extra
|
||||
FindlibParent: lwt
|
||||
Path: src/extra
|
||||
Modules: Lwt_lib
|
||||
BuildDepends: lwt, lwt.preemptive
|
||||
XMETADescription: Unix functions for Lwt using Lwt_preemptive
|
||||
|
||||
Library "lwt-glib"
|
||||
Build$: flag(glib) || flag(all)
|
||||
Install$: flag(glib) || flag(all)
|
||||
FindlibName: glib
|
||||
FindlibParent: lwt
|
||||
Path: src/glib
|
||||
Modules: Lwt_glib
|
||||
CSources: lwt_glib_stubs.c
|
||||
BuildDepends: lwt, lwt.unix
|
||||
XMETADescription: Glib integration
|
||||
|
||||
Library "lwt-ssl"
|
||||
Build$: flag(ssl) || flag(all)
|
||||
Install$: flag(ssl) || flag(all)
|
||||
FindlibName: ssl
|
||||
FindlibParent: lwt
|
||||
Path: src/ssl
|
||||
Modules: Lwt_ssl
|
||||
BuildDepends: ssl, lwt.unix
|
||||
XMETADescription: SSL support for Lwt
|
||||
|
||||
Library "lwt-text"
|
||||
Build$: flag(text) || flag(all)
|
||||
Install$: flag(text) || flag(all)
|
||||
FindlibName: text
|
||||
FindlibParent: lwt
|
||||
Path: src/text
|
||||
Modules: Lwt_text, Lwt_term, Lwt_read_line
|
||||
BuildDepends: lwt, lwt.unix, lwt.react, text, text.bigarray
|
||||
XMETADescription: Text mode utilities
|
||||
CSources: lwt_text_stubs.c
|
||||
|
||||
Library "lwt-top"
|
||||
Build$: flag(text) || flag(all)
|
||||
Install$: flag(text) || flag(all)
|
||||
FindlibName: top
|
||||
FindlibParent: lwt
|
||||
Path: src/top
|
||||
Modules: Lwt_top
|
||||
InternalModules: Lwt_ocaml_completion
|
||||
BuildDepends: lwt, lwt.text, findlib
|
||||
XMETADescription: Line-editing in the toplevel
|
||||
|
||||
Library "lwt-syntax"
|
||||
FindlibName: syntax
|
||||
FindlibParent: lwt
|
||||
Path: syntax
|
||||
Modules: Pa_lwt
|
||||
BuildDepends: camlp4.lib, camlp4.quotations.o, camlp4.extend
|
||||
XMETAType: syntax
|
||||
XMETADescription: Syntactic sugars for Lwt
|
||||
XMETARequires: camlp4, lwt.syntax.options
|
||||
|
||||
Library "lwt-syntax-options"
|
||||
FindlibName: options
|
||||
FindlibParent: lwt-syntax
|
||||
Path: syntax
|
||||
InternalModules: Pa_lwt_options
|
||||
BuildDepends: camlp4.lib
|
||||
XMETAType: syntax
|
||||
XMETADescription: Options for syntax extensions
|
||||
XMETARequires: camlp4
|
||||
|
||||
Library "lwt-syntax-log"
|
||||
FindlibName: log
|
||||
FindlibParent: lwt-syntax
|
||||
Path: syntax
|
||||
Modules: Pa_lwt_log
|
||||
BuildDepends: camlp4.lib, camlp4.quotations.o
|
||||
XMETAType: syntax
|
||||
XMETADescription: Syntactic sugars for logging
|
||||
XMETARequires: camlp4, lwt.syntax.options
|
||||
|
||||
# +-------------------------------------------------------------------+
|
||||
# | Toplevel |
|
||||
# +-------------------------------------------------------------------+
|
||||
|
||||
Executable "lwt-toplevel"
|
||||
Build$: flag(toplevel) || flag(all)
|
||||
Install$: flag(toplevel) || flag(all)
|
||||
Path: src/top
|
||||
CompiledObject: byte
|
||||
MainIs: lwt_toplevel.ml
|
||||
BuildDepends: lwt, lwt.top, lwt.text, lwt.react, text, findlib, unix
|
||||
|
||||
# +-------------------------------------------------------------------+
|
||||
# | Doc |
|
||||
# +-------------------------------------------------------------------+
|
||||
|
||||
Document "lwt-manual"
|
||||
Title: Lwt user manual
|
||||
Type: custom (0.2)
|
||||
Install: true
|
||||
XCustom: make -C manual manual.pdf
|
||||
DataFiles: manual/manual.pdf
|
||||
InstallDir: $pdfdir
|
||||
|
||||
Document "lwt-api"
|
||||
Title: API reference for Lwt
|
||||
Type: ocamlbuild (0.2)
|
||||
Install: true
|
||||
InstallDir: $htmldir/api
|
||||
DataFiles: utils/style.css
|
||||
BuildTools: ocamldoc
|
||||
XOCamlbuildPath: ./
|
||||
XOCamlbuildLibraries:
|
||||
lwt,
|
||||
lwt.extra,
|
||||
lwt.glib,
|
||||
lwt.preemptive,
|
||||
lwt.react,
|
||||
lwt.ssl,
|
||||
lwt.text,
|
||||
lwt.top,
|
||||
lwt.unix,
|
||||
lwt.syntax,
|
||||
lwt.syntax.log
|
||||
|
||||
# +-------------------------------------------------------------------+
|
||||
# | Examples |
|
||||
# +-------------------------------------------------------------------+
|
||||
|
||||
Executable logging
|
||||
Path: examples/unix
|
||||
Build$: flag(unix)
|
||||
Install: false
|
||||
MainIs: logging.ml
|
||||
BuildDepends: lwt.unix, lwt.syntax
|
||||
CompiledObject: best
|
||||
|
||||
Executable relay
|
||||
Path: examples/unix
|
||||
Build$: flag(unix)
|
||||
Install: false
|
||||
MainIs: relay.ml
|
||||
BuildDepends: lwt.unix, lwt.syntax
|
||||
CompiledObject: best
|
||||
|
||||
Executable parallelize
|
||||
Path: examples/unix
|
||||
Build$: flag(unix)
|
||||
Install: false
|
||||
MainIs: parallelize.ml
|
||||
BuildDepends: lwt.unix, lwt.syntax
|
||||
CompiledObject: best
|
||||
|
||||
# +-------------------------------------------------------------------+
|
||||
# | Tests |
|
||||
# +-------------------------------------------------------------------+
|
||||
|
||||
Library test
|
||||
Path: tests
|
||||
Modules: Test
|
||||
Install: false
|
||||
Build$: flag(unix) || flag(all)
|
||||
|
||||
Executable test_core
|
||||
Path: tests/core
|
||||
Build$: flag(unix) || flag(all)
|
||||
Install: false
|
||||
CompiledObject: best
|
||||
MainIs: main.ml
|
||||
BuildDepends: test, lwt, unix, lwt.unix
|
||||
|
||||
Executable test_unix
|
||||
Path: tests/unix
|
||||
Build$: flag(unix) || flag(all)
|
||||
Install: false
|
||||
CompiledObject: best
|
||||
MainIs: main.ml
|
||||
BuildDepends: test, lwt, unix, lwt.unix
|
||||
|
||||
Executable test_react
|
||||
Path: tests/react
|
||||
Build$: (flag(unix) && flag(react)) || flag(all)
|
||||
Install: false
|
||||
CompiledObject: best
|
||||
MainIs: main.ml
|
||||
BuildDepends: test, lwt, unix, lwt.unix, react, lwt.react
|
||||
|
||||
Test core
|
||||
Command: $test_core
|
||||
TestTools: test_core
|
||||
Run$: flag(unix) || flag(all)
|
||||
|
||||
Test unix
|
||||
Command: $test_unix
|
||||
TestTools: test_unix
|
||||
Run$: flag(unix) || flag(all)
|
||||
|
||||
Test react
|
||||
Command: $test_react
|
||||
TestTools: test_react
|
||||
Run$: (flag(unix) && flag(react)) || flag(all)
|
||||
|
||||
# +-------------------------------------------------------------------+
|
||||
# | Misc |
|
||||
# +-------------------------------------------------------------------+
|
||||
|
||||
SourceRepository head
|
||||
Type: darcs
|
||||
Location: http://ocsigen.org/darcs/lwt
|
||||
Browser: http://ocsigen.org/darcsweb/?r=lwt;a=summary
|
|
@ -0,0 +1,223 @@
|
|||
# -*- conf -*-
|
||||
|
||||
<**/*.ml>: syntax_camlp4o, pkg_camlp4
|
||||
<**/*.ml>: pa_lwt_options, pa_lwt, pa_lwt_log, pa_optcomp
|
||||
<syntax/*.ml>: -pa_lwt_options, -pa_lwt, -pa_lwt_log, -pa_optcomp
|
||||
|
||||
<src/top/{lwt_toplevel.*,toplevel.*,toplevel_temp.*}>: use_compiler_libs, pkg_text, pkg_text.bigarray, pkg_findlib, pkg_react, pkg_unix, pkg_bigarray
|
||||
|
||||
<src/{unix,glib,text}/*>: use_stubs
|
||||
|
||||
"src/unix/lwt_io.mli": syntax_camlp4o, pkg_camlp4, pa_optcomp
|
||||
|
||||
# GLib bindings:
|
||||
<src/glib/lwt-glib.*>: use_C_glib
|
||||
<src/glib/liblwt-glib.*>: use_C_glib
|
||||
<src/glib/lwt_glib_stubs.*>: use_C_glib
|
||||
|
||||
# OASIS_START
|
||||
# DO NOT EDIT (digest: 1e926c0b1533824658bafa01bc7a4af4)
|
||||
# Library lwt
|
||||
"src/core": include
|
||||
"src/core/lwt.cmxs": use_lwt
|
||||
# Library lwt-unix
|
||||
"src/unix": include
|
||||
"src/unix/lwt-unix.cmxs": use_lwt-unix
|
||||
<src/unix/lwt-unix.{cma,cmxa}>: oasis_library_lwt_unix_cclib
|
||||
"src/unix/liblwt-unix.lib": oasis_library_lwt_unix_cclib
|
||||
"src/unix/dlllwt-unix.dll": oasis_library_lwt_unix_cclib
|
||||
"src/unix/liblwt-unix.a": oasis_library_lwt_unix_cclib
|
||||
"src/unix/dlllwt-unix.so": oasis_library_lwt_unix_cclib
|
||||
<src/unix/lwt-unix.{cma,cmxa}>: use_liblwt-unix
|
||||
<src/unix/*.ml{,i}>: use_lwt
|
||||
<src/unix/*.ml{,i}>: pkg_unix
|
||||
<src/unix/*.ml{,i}>: pkg_bigarray
|
||||
"src/unix/lwt_unix_stubs.c": use_lwt
|
||||
"src/unix/lwt_unix_stubs.c": pkg_unix
|
||||
"src/unix/lwt_unix_stubs.c": pkg_bigarray
|
||||
"src/unix/lwt_libev_stubs.c": use_lwt
|
||||
"src/unix/lwt_libev_stubs.c": pkg_unix
|
||||
"src/unix/lwt_libev_stubs.c": pkg_bigarray
|
||||
# Library lwt-react
|
||||
"src/react": include
|
||||
"src/react/lwt-react.cmxs": use_lwt-react
|
||||
<src/react/*.ml{,i}>: use_lwt
|
||||
<src/react/*.ml{,i}>: pkg_react
|
||||
# Library test
|
||||
"tests": include
|
||||
"tests/test.cmxs": use_test
|
||||
# Library lwt-text
|
||||
"src/text": include
|
||||
"src/text/lwt-text.cmxs": use_lwt-text
|
||||
<src/text/lwt-text.{cma,cmxa}>: use_liblwt-text
|
||||
<src/text/*.ml{,i}>: use_lwt-react
|
||||
<src/text/*.ml{,i}>: use_lwt-unix
|
||||
<src/text/*.ml{,i}>: use_lwt
|
||||
<src/text/*.ml{,i}>: pkg_unix
|
||||
<src/text/*.ml{,i}>: pkg_text.bigarray
|
||||
<src/text/*.ml{,i}>: pkg_text
|
||||
<src/text/*.ml{,i}>: pkg_react
|
||||
<src/text/*.ml{,i}>: pkg_bigarray
|
||||
"src/text/lwt_text_stubs.c": use_lwt-react
|
||||
"src/text/lwt_text_stubs.c": use_lwt-unix
|
||||
"src/text/lwt_text_stubs.c": use_lwt
|
||||
"src/text/lwt_text_stubs.c": pkg_unix
|
||||
"src/text/lwt_text_stubs.c": pkg_text.bigarray
|
||||
"src/text/lwt_text_stubs.c": pkg_text
|
||||
"src/text/lwt_text_stubs.c": pkg_react
|
||||
"src/text/lwt_text_stubs.c": pkg_bigarray
|
||||
# Executable test_unix
|
||||
<tests/unix/main.{native,byte}>: use_test
|
||||
<tests/unix/main.{native,byte}>: use_lwt-unix
|
||||
<tests/unix/main.{native,byte}>: use_lwt
|
||||
<tests/unix/main.{native,byte}>: pkg_unix
|
||||
<tests/unix/main.{native,byte}>: pkg_bigarray
|
||||
<tests/unix/*.ml{,i}>: use_test
|
||||
<tests/unix/*.ml{,i}>: use_lwt-unix
|
||||
<tests/unix/*.ml{,i}>: use_lwt
|
||||
<tests/unix/*.ml{,i}>: pkg_unix
|
||||
<tests/unix/*.ml{,i}>: pkg_bigarray
|
||||
# Library lwt-syntax
|
||||
"syntax/lwt-syntax.cmxs": use_lwt-syntax
|
||||
<syntax/*.ml{,i}>: pkg_camlp4.extend
|
||||
# Executable test_react
|
||||
<tests/react/main.{native,byte}>: use_test
|
||||
<tests/react/main.{native,byte}>: use_lwt-react
|
||||
<tests/react/main.{native,byte}>: use_lwt-unix
|
||||
<tests/react/main.{native,byte}>: use_lwt
|
||||
<tests/react/main.{native,byte}>: pkg_unix
|
||||
<tests/react/main.{native,byte}>: pkg_react
|
||||
<tests/react/main.{native,byte}>: pkg_bigarray
|
||||
<tests/react/*.ml{,i}>: use_test
|
||||
<tests/react/*.ml{,i}>: use_lwt-react
|
||||
<tests/react/*.ml{,i}>: use_lwt-unix
|
||||
<tests/react/*.ml{,i}>: use_lwt
|
||||
<tests/react/*.ml{,i}>: pkg_unix
|
||||
<tests/react/*.ml{,i}>: pkg_react
|
||||
<tests/react/*.ml{,i}>: pkg_bigarray
|
||||
# Executable test_core
|
||||
<tests/core/main.{native,byte}>: use_test
|
||||
<tests/core/main.{native,byte}>: use_lwt-unix
|
||||
<tests/core/main.{native,byte}>: use_lwt
|
||||
<tests/core/main.{native,byte}>: pkg_unix
|
||||
<tests/core/main.{native,byte}>: pkg_bigarray
|
||||
<tests/core/*.ml{,i}>: use_test
|
||||
<tests/core/*.ml{,i}>: use_lwt-unix
|
||||
<tests/core/*.ml{,i}>: use_lwt
|
||||
<tests/core/*.ml{,i}>: pkg_unix
|
||||
<tests/core/*.ml{,i}>: pkg_bigarray
|
||||
# Library lwt-top
|
||||
"src/top": include
|
||||
"src/top/lwt-top.cmxs": use_lwt-top
|
||||
# Library lwt-preemptive
|
||||
"src/preemptive": include
|
||||
"src/preemptive/lwt-preemptive.cmxs": use_lwt-preemptive
|
||||
<src/preemptive/*.ml{,i}>: use_lwt-unix
|
||||
<src/preemptive/*.ml{,i}>: use_lwt
|
||||
<src/preemptive/*.ml{,i}>: pkg_unix
|
||||
<src/preemptive/*.ml{,i}>: pkg_threads
|
||||
<src/preemptive/*.ml{,i}>: pkg_bigarray
|
||||
# Library lwt-simple-top
|
||||
"src/simple_top": include
|
||||
"src/simple_top/lwt-simple-top.cmxs": use_lwt-simple-top
|
||||
<src/simple_top/*.ml{,i}>: use_lwt-unix
|
||||
<src/simple_top/*.ml{,i}>: use_lwt
|
||||
<src/simple_top/*.ml{,i}>: pkg_unix
|
||||
<src/simple_top/*.ml{,i}>: pkg_bigarray
|
||||
# Library lwt-glib
|
||||
"src/glib": include
|
||||
"src/glib/lwt-glib.cmxs": use_lwt-glib
|
||||
<src/glib/lwt-glib.{cma,cmxa}>: use_liblwt-glib
|
||||
<src/glib/*.ml{,i}>: use_lwt-unix
|
||||
<src/glib/*.ml{,i}>: use_lwt
|
||||
<src/glib/*.ml{,i}>: pkg_unix
|
||||
<src/glib/*.ml{,i}>: pkg_bigarray
|
||||
"src/glib/lwt_glib_stubs.c": use_lwt-unix
|
||||
"src/glib/lwt_glib_stubs.c": use_lwt
|
||||
"src/glib/lwt_glib_stubs.c": pkg_unix
|
||||
"src/glib/lwt_glib_stubs.c": pkg_bigarray
|
||||
# Executable relay
|
||||
<examples/unix/relay.{native,byte}>: use_lwt-syntax
|
||||
<examples/unix/relay.{native,byte}>: use_lwt-unix
|
||||
<examples/unix/relay.{native,byte}>: use_lwt
|
||||
<examples/unix/relay.{native,byte}>: pkg_unix
|
||||
<examples/unix/relay.{native,byte}>: pkg_camlp4.quotations.o
|
||||
<examples/unix/relay.{native,byte}>: pkg_camlp4.lib
|
||||
<examples/unix/relay.{native,byte}>: pkg_camlp4.extend
|
||||
<examples/unix/relay.{native,byte}>: pkg_bigarray
|
||||
# Executable logging
|
||||
<examples/unix/logging.{native,byte}>: use_lwt-syntax
|
||||
<examples/unix/logging.{native,byte}>: use_lwt-unix
|
||||
<examples/unix/logging.{native,byte}>: use_lwt
|
||||
<examples/unix/logging.{native,byte}>: pkg_unix
|
||||
<examples/unix/logging.{native,byte}>: pkg_camlp4.quotations.o
|
||||
<examples/unix/logging.{native,byte}>: pkg_camlp4.lib
|
||||
<examples/unix/logging.{native,byte}>: pkg_camlp4.extend
|
||||
<examples/unix/logging.{native,byte}>: pkg_bigarray
|
||||
# Library lwt-syntax-log
|
||||
"syntax/lwt-syntax-log.cmxs": use_lwt-syntax-log
|
||||
# Executable lwt-toplevel
|
||||
"src/top/lwt_toplevel.byte": use_lwt-top
|
||||
"src/top/lwt_toplevel.byte": use_lwt-text
|
||||
"src/top/lwt_toplevel.byte": use_lwt-react
|
||||
"src/top/lwt_toplevel.byte": use_lwt-unix
|
||||
"src/top/lwt_toplevel.byte": use_lwt
|
||||
"src/top/lwt_toplevel.byte": pkg_unix
|
||||
"src/top/lwt_toplevel.byte": pkg_text.bigarray
|
||||
"src/top/lwt_toplevel.byte": pkg_text
|
||||
"src/top/lwt_toplevel.byte": pkg_react
|
||||
"src/top/lwt_toplevel.byte": pkg_findlib
|
||||
"src/top/lwt_toplevel.byte": pkg_bigarray
|
||||
<src/top/*.ml{,i}>: use_lwt-top
|
||||
<src/top/*.ml{,i}>: use_lwt-text
|
||||
<src/top/*.ml{,i}>: use_lwt-react
|
||||
<src/top/*.ml{,i}>: use_lwt-unix
|
||||
<src/top/*.ml{,i}>: use_lwt
|
||||
<src/top/*.ml{,i}>: pkg_unix
|
||||
<src/top/*.ml{,i}>: pkg_text.bigarray
|
||||
<src/top/*.ml{,i}>: pkg_text
|
||||
<src/top/*.ml{,i}>: pkg_react
|
||||
<src/top/*.ml{,i}>: pkg_findlib
|
||||
<src/top/*.ml{,i}>: pkg_bigarray
|
||||
# Executable parallelize
|
||||
<examples/unix/parallelize.{native,byte}>: use_lwt-syntax
|
||||
<examples/unix/parallelize.{native,byte}>: use_lwt-unix
|
||||
<examples/unix/parallelize.{native,byte}>: use_lwt
|
||||
<examples/unix/parallelize.{native,byte}>: pkg_unix
|
||||
<examples/unix/parallelize.{native,byte}>: pkg_camlp4.quotations.o
|
||||
<examples/unix/parallelize.{native,byte}>: pkg_camlp4.lib
|
||||
<examples/unix/parallelize.{native,byte}>: pkg_camlp4.extend
|
||||
<examples/unix/parallelize.{native,byte}>: pkg_bigarray
|
||||
<examples/unix/*.ml{,i}>: use_lwt-syntax
|
||||
<examples/unix/*.ml{,i}>: use_lwt-unix
|
||||
<examples/unix/*.ml{,i}>: use_lwt
|
||||
<examples/unix/*.ml{,i}>: pkg_unix
|
||||
<examples/unix/*.ml{,i}>: pkg_camlp4.quotations.o
|
||||
<examples/unix/*.ml{,i}>: pkg_camlp4.lib
|
||||
<examples/unix/*.ml{,i}>: pkg_camlp4.extend
|
||||
<examples/unix/*.ml{,i}>: pkg_bigarray
|
||||
# Library lwt-extra
|
||||
"src/extra": include
|
||||
"src/extra/lwt-extra.cmxs": use_lwt-extra
|
||||
<src/extra/*.ml{,i}>: use_lwt-preemptive
|
||||
<src/extra/*.ml{,i}>: use_lwt-unix
|
||||
<src/extra/*.ml{,i}>: use_lwt
|
||||
<src/extra/*.ml{,i}>: pkg_unix
|
||||
<src/extra/*.ml{,i}>: pkg_threads
|
||||
<src/extra/*.ml{,i}>: pkg_bigarray
|
||||
# Library optcomp
|
||||
"syntax/optcomp.cmxs": use_optcomp
|
||||
<syntax/*.ml{,i}>: pkg_camlp4.quotations.o
|
||||
# Library lwt-syntax-options
|
||||
"syntax": include
|
||||
"syntax/lwt-syntax-options.cmxs": use_lwt-syntax-options
|
||||
<syntax/*.ml{,i}>: pkg_camlp4.lib
|
||||
# Library lwt-ssl
|
||||
"src/ssl": include
|
||||
"src/ssl/lwt-ssl.cmxs": use_lwt-ssl
|
||||
<src/ssl/*.ml{,i}>: use_lwt-unix
|
||||
<src/ssl/*.ml{,i}>: use_lwt
|
||||
<src/ssl/*.ml{,i}>: pkg_unix
|
||||
<src/ssl/*.ml{,i}>: pkg_ssl
|
||||
<src/ssl/*.ml{,i}>: pkg_bigarray
|
||||
# OASIS_STOP
|
|
@ -0,0 +1,109 @@
|
|||
{1 Lwt - API Reference}
|
||||
|
||||
{2 Core library}
|
||||
|
||||
The {e core} library ({e lwt} package) contains the {!Lwt} module, which defines
|
||||
cooperative threads with all the primitives to manipulate them. It
|
||||
also provides several general purpose modules, which do not depend on
|
||||
any external package.
|
||||
|
||||
{!modules:
|
||||
Lwt
|
||||
Lwt_condition
|
||||
Lwt_list
|
||||
Lwt_mutex
|
||||
Lwt_mvar
|
||||
Lwt_pool
|
||||
Lwt_sequence
|
||||
Lwt_pqueue
|
||||
Lwt_stream
|
||||
Lwt_switch
|
||||
}
|
||||
|
||||
{2 Unix bindings}
|
||||
|
||||
The {e lwt.unix} package provides:
|
||||
- the {!Lwt_unix} module, which wrap system calls into cooperative ones
|
||||
- the {!Lwt_io} module, which defines cooperative byte channel, in
|
||||
replacement of ones of the standard library
|
||||
- module helpers for logging, spawning processes, ...
|
||||
|
||||
{!modules:
|
||||
Lwt_daemon
|
||||
Lwt_gc
|
||||
Lwt_io
|
||||
Lwt_log
|
||||
Lwt_main
|
||||
Lwt_engine
|
||||
Lwt_process
|
||||
Lwt_throttle
|
||||
Lwt_timeout
|
||||
Lwt_unix
|
||||
Lwt_bytes
|
||||
Lwt_sys
|
||||
}
|
||||
|
||||
This package depends on the {e core} library and the {e unix} package.
|
||||
|
||||
{2 Reactive programming helpers}
|
||||
|
||||
The {e lwt.react} package provides helpers for functionnal reactive
|
||||
programming with Lwt. It is based on the {e react} package. The
|
||||
{!Lwt_react} module is a replacement for the [React] module. It
|
||||
contains:
|
||||
|
||||
- all the functions of the [React] module
|
||||
- Lwt specific primitives
|
||||
- cooperative versions of {e react} functions
|
||||
|
||||
{!modules:
|
||||
Lwt_react
|
||||
}
|
||||
|
||||
This package depends on the {e core} library and the {e react} package.
|
||||
|
||||
{2 Syntax extensions}
|
||||
|
||||
Lwt is shipped with two syntax extensions. The first one, contained in
|
||||
the {e lwt.syntax} package, aims to make coding with Lwt easier, and
|
||||
to make code more readable. The second, contained in the package {e
|
||||
lwt.syntax.log}, is a camlp4 filter which decreases the performance
|
||||
penalty when using logging by inlining level tests.
|
||||
|
||||
{!modules:
|
||||
Pa_lwt
|
||||
Pa_lwt_log
|
||||
}
|
||||
|
||||
{2 Terminal manipulation}
|
||||
|
||||
The package {e lwt.text} provides:
|
||||
- terminal manipulation through the module {!Lwt_term}
|
||||
- text channels which behaves as byte channels but are aware of the
|
||||
text encoding
|
||||
- a cooperative, fully customizable read-line facility
|
||||
|
||||
{!modules:
|
||||
Lwt_read_line
|
||||
Lwt_term
|
||||
Lwt_text
|
||||
}
|
||||
|
||||
This package depends on the {e core} library, and the {e lwt.react},
|
||||
{e lwt.unix}, {e text} packages.
|
||||
|
||||
{2 Miscellaneous}
|
||||
|
||||
The following modules are wrapper for integration of non-Lwt
|
||||
functions/packages into Lwt.
|
||||
|
||||
{!modules:
|
||||
Lwt_glib
|
||||
Lwt_lib
|
||||
Lwt_preemptive
|
||||
Lwt_ssl
|
||||
}
|
||||
|
||||
{2 Index}
|
||||
|
||||
{!indexlist}
|
|
@ -0,0 +1,8 @@
|
|||
#!/bin/sh
|
||||
|
||||
# OASIS_START
|
||||
# DO NOT EDIT (digest: ed33e59fe00e48bc31edf413bbc8b8d6)
|
||||
set -e
|
||||
|
||||
ocaml setup.ml -configure $*
|
||||
# OASIS_STOP
|
|
@ -0,0 +1,294 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Program discover
|
||||
* Copyright (C) 2010 Jérémie Dimino
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
(* Discover available features *)
|
||||
|
||||
(* Keep that in sync with the list in myocamlbuild.ml *)
|
||||
let search_paths = [
|
||||
"/usr";
|
||||
"/usr/local";
|
||||
"/opt";
|
||||
"/opt/local";
|
||||
"/sw";
|
||||
"/mingw";
|
||||
]
|
||||
|
||||
open Printf
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Test codes |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let caml_code = "
|
||||
external test : unit -> unit = \"lwt_test\"
|
||||
let () = test ()
|
||||
"
|
||||
|
||||
let pthread_code = "
|
||||
#include <caml/mlvalues.h>
|
||||
#include <pthread.h>
|
||||
|
||||
CAMLprim value lwt_test()
|
||||
{
|
||||
pthread_create(0, 0, 0, 0);
|
||||
return Val_unit;
|
||||
}
|
||||
"
|
||||
|
||||
let libev_code = "
|
||||
#include <caml/mlvalues.h>
|
||||
#include <ev.h>
|
||||
|
||||
CAMLprim value lwt_test()
|
||||
{
|
||||
ev_default_loop(0);
|
||||
return Val_unit;
|
||||
}
|
||||
"
|
||||
|
||||
let fd_passing_code = "
|
||||
#include <caml/mlvalues.h>
|
||||
#include <sys/types.h>
|
||||
#include <sys/socket.h>
|
||||
|
||||
CAMLprim value lwt_test()
|
||||
{
|
||||
struct msghdr msg;
|
||||
msg.msg_controllen = 0;
|
||||
msg.msg_control = 0;
|
||||
return Val_unit;
|
||||
}
|
||||
"
|
||||
|
||||
let getcpu_code = "
|
||||
#include <caml/mlvalues.h>
|
||||
#define _GNU_SOURCE
|
||||
#include <sched.h>
|
||||
|
||||
CAMLprim value lwt_test()
|
||||
{
|
||||
sched_getcpu();
|
||||
return Val_unit;
|
||||
}
|
||||
"
|
||||
|
||||
let affinity_code = "
|
||||
#include <caml/mlvalues.h>
|
||||
#define _GNU_SOURCE
|
||||
#include <sched.h>
|
||||
|
||||
CAMLprim value lwt_test()
|
||||
{
|
||||
sched_getaffinity(0, 0, 0);
|
||||
return Val_unit;
|
||||
}
|
||||
"
|
||||
|
||||
let eventfd_code = "
|
||||
#include <caml/mlvalues.h>
|
||||
#include <sys/eventfd.h>
|
||||
|
||||
CAMLprim value lwt_test()
|
||||
{
|
||||
eventfd(0, 0);
|
||||
return Val_unit;
|
||||
}
|
||||
"
|
||||
|
||||
let get_credentials_code = "
|
||||
#include <caml/mlvalues.h>
|
||||
#include <sys/types.h>
|
||||
#include <sys/socket.h>
|
||||
|
||||
CAMLprim value lwt_test()
|
||||
{
|
||||
getsockopt(0, SOL_SOCKET, SO_PEERCRED, 0, 0);
|
||||
return Val_unit;
|
||||
}
|
||||
"
|
||||
|
||||
let fdatasync_code = "
|
||||
#include <caml/mlvalues.h>
|
||||
#include <sys/unistd.h>
|
||||
|
||||
CAMLprim value lwt_test()
|
||||
{
|
||||
fdatasync(0);
|
||||
return Val_unit;
|
||||
}
|
||||
"
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Compilation |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let ocamlc = ref "ocamlc"
|
||||
let ext_obj = ref ".o"
|
||||
let exec_name = ref "a.out"
|
||||
let use_libev = ref true
|
||||
let os_type = ref "Unix"
|
||||
|
||||
let log_file = ref ""
|
||||
let caml_file = ref ""
|
||||
|
||||
(* Search for a header file in standard directories. *)
|
||||
let search_header header =
|
||||
let rec loop = function
|
||||
| [] ->
|
||||
None
|
||||
| dir :: dirs ->
|
||||
if Sys.file_exists (dir ^ "/include/" ^ header) then
|
||||
Some dir
|
||||
else
|
||||
loop dirs
|
||||
in
|
||||
loop search_paths
|
||||
|
||||
let c_args =
|
||||
let flags path = Printf.sprintf "-ccopt -I%s/include -cclib -L%s/lib" path path in
|
||||
match search_header "ev.h", search_header "pthread.h" with
|
||||
| None, None -> ""
|
||||
| Some path, None | None, Some path -> flags path
|
||||
| Some path1, Some path2 when path1 = path2 -> flags path1
|
||||
| Some path1, Some path2 -> flags path1 ^ " " ^ flags path2
|
||||
|
||||
let compile args stub_file =
|
||||
ksprintf
|
||||
Sys.command
|
||||
"%s -custom %s %s %s %s > %s 2>&1"
|
||||
!ocamlc
|
||||
c_args
|
||||
(Filename.quote stub_file)
|
||||
args
|
||||
(Filename.quote !caml_file)
|
||||
(Filename.quote !log_file)
|
||||
= 0
|
||||
|
||||
let safe_remove file_name =
|
||||
try
|
||||
Sys.remove file_name
|
||||
with exn ->
|
||||
()
|
||||
|
||||
let test_code args stub_code =
|
||||
let stub_file, oc = Filename.open_temp_file "lwt_stub" ".c" in
|
||||
let cleanup () =
|
||||
safe_remove stub_file;
|
||||
safe_remove (Filename.chop_extension (Filename.basename stub_file) ^ !ext_obj)
|
||||
in
|
||||
try
|
||||
output_string oc stub_code;
|
||||
flush oc;
|
||||
close_out oc;
|
||||
let result = compile args stub_file in
|
||||
cleanup ();
|
||||
result
|
||||
with exn ->
|
||||
(try close_out oc with _ -> ());
|
||||
cleanup ();
|
||||
raise exn
|
||||
|
||||
let config = open_out "src/unix/lwt_config.h"
|
||||
let config_ml = open_out "src/unix/lwt_config.ml"
|
||||
|
||||
let test_feature ?(do_check = true) name macro ?(args="") code =
|
||||
if do_check then begin
|
||||
printf "testing for %s:%!" name;
|
||||
if test_code args code then begin
|
||||
fprintf config "#define %s\n" macro;
|
||||
fprintf config_ml "#let %s = true\n" macro;
|
||||
printf " %s available\n%!" (String.make (34 - String.length name) '.');
|
||||
true
|
||||
end else begin
|
||||
fprintf config "//#define %s\n" macro;
|
||||
fprintf config_ml "#let %s = false\n" macro;
|
||||
printf " %s unavailable\n%!" (String.make (34 - String.length name) '.');
|
||||
false
|
||||
end
|
||||
end else begin
|
||||
printf "not checking for %s\n%!" name;
|
||||
fprintf config "//#define %s\n" macro;
|
||||
fprintf config_ml "#let %s = false\n" macro;
|
||||
true
|
||||
end
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Entry point |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let () =
|
||||
let args = [
|
||||
"-ocamlc", Arg.Set_string ocamlc, "<path> ocamlc";
|
||||
"-ext-obj", Arg.Set_string ext_obj, "<ext> C object files extension";
|
||||
"-exec-name", Arg.Set_string exec_name, "<name> name of the executable produced by ocamlc";
|
||||
"-use-libev", Arg.Symbol (["true"; "false"],
|
||||
function
|
||||
| "true" -> use_libev := true
|
||||
| "false" -> use_libev := false
|
||||
| _ -> assert false), " whether to check for libev";
|
||||
"-os-type", Arg.Set_string os_type, "<name> type of the target os";
|
||||
] in
|
||||
Arg.parse args ignore "check for external C libraries and available features\noptions are:";
|
||||
|
||||
(* Put the caml code into a temporary file. *)
|
||||
let file, oc = Filename.open_temp_file "lwt_caml" ".ml" in
|
||||
caml_file := file;
|
||||
output_string oc caml_code;
|
||||
close_out oc;
|
||||
|
||||
log_file := Filename.temp_file "lwt_output" ".log";
|
||||
|
||||
(* Cleanup things on exit. *)
|
||||
at_exit (fun () ->
|
||||
(try close_out config with _ -> ());
|
||||
(try close_out config_ml with _ -> ());
|
||||
safe_remove !log_file;
|
||||
safe_remove !exec_name;
|
||||
safe_remove !caml_file;
|
||||
safe_remove (Filename.chop_extension !caml_file ^ ".cmi");
|
||||
safe_remove (Filename.chop_extension !caml_file ^ ".cmo"));
|
||||
|
||||
let missing = [] in
|
||||
let missing = if test_feature ~do_check:!use_libev "libev" "HAVE_LIBEV" ~args:"-cclib -lev" libev_code then missing else "libev" :: missing in
|
||||
let missing = if test_feature ~do_check:(!os_type <> "Win32") "pthread" "HAVE_PTHREAD" ~args:"-cclib -lpthread" pthread_code then missing else "pthread" :: missing in
|
||||
|
||||
if missing <> [] then begin
|
||||
printf "
|
||||
The following recquired C libraries are missing: %s.
|
||||
Please install them and retry. If they are installed in a non-standard location, set the environment variables C_INCLUDE_PATH and LIBRARY_PATH accordingly and retry.
|
||||
|
||||
For example, if they are installed in /opt/local, you can type:
|
||||
|
||||
export C_INCLUDE_PATH=/opt/local/include
|
||||
export LIBRARY_PATH=/opt/local/lib
|
||||
|
||||
To compile without libev support, use ./configure --disable-libev ...
|
||||
" (String.concat ", " missing);
|
||||
exit 1
|
||||
end;
|
||||
|
||||
ignore (test_feature "eventfd" "HAVE_EVENTFD" eventfd_code);
|
||||
ignore (test_feature "fd passing" "HAVE_FD_PASSING" fd_passing_code);
|
||||
ignore (test_feature "sched_getcpu" "HAVE_GETCPU" getcpu_code);
|
||||
ignore (test_feature "affinity getting/setting" "HAVE_AFFINITY" affinity_code);
|
||||
ignore (test_feature "credentials getting" "HAVE_GET_CREDENTIALS" get_credentials_code);
|
||||
ignore (test_feature "fdatasync" "HAVE_FDATASYNC" fdatasync_code)
|
|
@ -0,0 +1,2 @@
|
|||
all:
|
||||
ocamlbuild -use-ocamlfind -classic-display -tag 'syntax(camlp4o)' -package lwt.unix,lwt.glib,lwt.syntax,lablgtk2 connect.byte
|
|
@ -0,0 +1,218 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Program Connect
|
||||
* Copyright (C) 2011 Jérémie Dimino
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
(* A simple graphical telnet. *)
|
||||
|
||||
open Lwt
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Utils |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let show_error fmt =
|
||||
Printf.ksprintf
|
||||
(fun message ->
|
||||
let dialog = GWindow.message_dialog ~message_type:`ERROR ~buttons:GWindow.Buttons.ok ~message () in
|
||||
ignore (dialog#connect#response (function
|
||||
| `DELETE_EVENT -> ()
|
||||
| `OK -> dialog#destroy ()));
|
||||
dialog#show ())
|
||||
fmt
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Connection |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
(* Either [None] if we are not connected, either [Some (ic, oc,
|
||||
thread)] if we are connected. In this last case [thread] is the
|
||||
thread reading data from the connection. *)
|
||||
let connection = ref None
|
||||
|
||||
(* Read continously data from [ic] and write them to [view]. *)
|
||||
let read ic (view : GText.view) =
|
||||
let rec loop () =
|
||||
match_lwt Lwt_io.read_line_opt ic with
|
||||
| Some line ->
|
||||
view#buffer#insert ~iter:view#buffer#end_iter ~tag_names:["recv"] (line ^ "\n");
|
||||
loop ()
|
||||
| None ->
|
||||
view#buffer#insert ~iter:view#buffer#end_iter "end of connection\n";
|
||||
Lwt_io.close ic
|
||||
in
|
||||
try_lwt
|
||||
loop ()
|
||||
with Unix.Unix_error (error, _, _) ->
|
||||
show_error "reading error: %s" (Unix.error_message error);
|
||||
return ()
|
||||
|
||||
(* Function called when the user active the [connect] menu
|
||||
item. [view] is the text view used to display data received from
|
||||
the connection. *)
|
||||
let connect (view : GText.view) =
|
||||
(* Create a popup for asking the address and port to connect to. *)
|
||||
let dialog = GWindow.dialog ~title:"connection" () in
|
||||
dialog#add_button_stock `OK `OK;
|
||||
dialog#add_button_stock `CANCEL `CANCEL;
|
||||
let hbox = GPack.hbox ~packing:dialog#vbox#add () in
|
||||
ignore (GMisc.label ~packing:hbox#add ~text:"host: " ());
|
||||
let host = GEdit.entry ~packing:hbox#add ~text:"127.0.0.1" () in
|
||||
ignore (GMisc.label ~packing:hbox#add ~text:" port: " ());
|
||||
let port = GEdit.spin_button ~digits:0 ~numeric:true ~packing:hbox#add () in
|
||||
port#adjustment#set_bounds ~lower:0. ~upper:(float max_int) ~step_incr:1. ();
|
||||
|
||||
(* Thread waiting for the popup to be closed. *)
|
||||
let waiter, wakener = wait () in
|
||||
|
||||
(* Wakeup the thread when the popup is closed. *)
|
||||
ignore (dialog#connect#response (wakeup wakener));
|
||||
|
||||
dialog#show ();
|
||||
|
||||
ignore (
|
||||
match_lwt waiter with
|
||||
| `DELETE_EVENT ->
|
||||
return ()
|
||||
| `CANCEL ->
|
||||
dialog#destroy ();
|
||||
return ()
|
||||
| `OK ->
|
||||
let host = host#text and port = int_of_float port#value in
|
||||
dialog#destroy ();
|
||||
try_lwt
|
||||
(* Resolve the address. *)
|
||||
lwt entry = Lwt_unix.gethostbyname host in
|
||||
if Array.length entry.Unix.h_addr_list = 0 then begin
|
||||
show_error "no address found for host %S" host;
|
||||
return ()
|
||||
end else begin
|
||||
lwt ic, oc = Lwt_io.open_connection (Unix.ADDR_INET (entry.Unix.h_addr_list.(0), port)) in
|
||||
(* Close the previous connection. *)
|
||||
lwt () =
|
||||
match !connection with
|
||||
| None ->
|
||||
return ()
|
||||
| Some (ic, oc, thread) ->
|
||||
cancel thread;
|
||||
try_lwt
|
||||
Lwt_io.close ic <&> Lwt_io.close oc
|
||||
with Unix.Unix_error (error, _, _) ->
|
||||
show_error "cannot close the connection: %s" (Unix.error_message error);
|
||||
return ()
|
||||
in
|
||||
(* Clear the buffer. *)
|
||||
view#buffer#delete view#buffer#start_iter view#buffer#end_iter;
|
||||
connection := Some (ic, oc, read ic view);
|
||||
return ()
|
||||
end
|
||||
with
|
||||
| Unix.Unix_error (error, _, _) ->
|
||||
show_error "cannot establish the connection: %s" (Unix.error_message error);
|
||||
return ()
|
||||
| Not_found ->
|
||||
show_error "host %S not found" host;
|
||||
return ()
|
||||
)
|
||||
|
||||
(* Send some data. *)
|
||||
let write (view : GText.view) (entry : GEdit.entry) =
|
||||
let text = entry#text in
|
||||
entry#set_text "";
|
||||
match !connection with
|
||||
| Some (ic, oc, thread) ->
|
||||
view#buffer#insert ~iter:view#buffer#end_iter ~tag_names:["send"] (text ^ "\n");
|
||||
ignore (
|
||||
try_lwt
|
||||
Lwt_io.write_line oc text
|
||||
with Unix.Unix_error (error, _, _) ->
|
||||
show_error "cannot send line: %s" (Unix.error_message error);
|
||||
return ()
|
||||
)
|
||||
| None ->
|
||||
show_error "not connected"
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Entry point |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
lwt () =
|
||||
(* Initializes GTK. *)
|
||||
ignore (GMain.init ~setlocale:false ());
|
||||
|
||||
(* Integrate Lwt with Glib. *)
|
||||
Lwt_glib.install ();
|
||||
|
||||
(* Create the UI. *)
|
||||
let window = GWindow.window ~title:"simple graphical telnet in OCaml with Lwt" ~allow_shrink:true ~width:640 ~height:480 () in
|
||||
let vbox = GPack.vbox ~packing:window#add () in
|
||||
|
||||
(* Create the menu. *)
|
||||
let menu = GMenu.menu_bar ~packing:(vbox#pack ~expand:false) () in
|
||||
let menu_file = GMenu.menu ~packing:(GMenu.menu_item ~label:"File" ~packing:menu#add ())#set_submenu () in
|
||||
let menu_connect = GMenu.image_menu_item ~label:"Connect" ~packing:menu_file#add ~stock:`CONNECT () in
|
||||
ignore (GMenu.separator_item ~packing:menu_file#add ());
|
||||
let menu_quit = GMenu.image_menu_item ~label:"Quit" ~packing:menu_file#add ~stock:`QUIT () in
|
||||
|
||||
(* The text view displaying inputs and outputs. *)
|
||||
let view =
|
||||
GText.view
|
||||
~editable:false
|
||||
~packing:(GBin.scrolled_window
|
||||
~hpolicy:`AUTOMATIC
|
||||
~vpolicy:`AUTOMATIC
|
||||
~packing:(GBin.frame
|
||||
~label:"log"
|
||||
~packing:vbox#add
|
||||
())#add
|
||||
())#add
|
||||
()
|
||||
in
|
||||
|
||||
ignore (view#buffer#create_tag ~name:"send" [`FOREGROUND "blue"]);
|
||||
ignore (view#buffer#create_tag ~name:"recv" [`FOREGROUND "#007f00"]);
|
||||
|
||||
let hbox = GPack.hbox ~packing:(GBin.frame ~label:"input" ~packing:(vbox#pack ~expand:false) ())#add () in
|
||||
|
||||
(* The entry for user input. *)
|
||||
let entry = GEdit.entry ~packing:hbox#add () in
|
||||
let send = GButton.button ~label:"send" ~packing:(hbox#pack ~expand:false) () in
|
||||
|
||||
(* Try to use a monospace font. *)
|
||||
(try
|
||||
view#misc#modify_font_by_name "Monospace";
|
||||
entry#misc#modify_font_by_name "Monospace"
|
||||
with _ ->
|
||||
());
|
||||
|
||||
(* Thread waiting for the main window to be closed. *)
|
||||
let waiter, wakener = wait () in
|
||||
|
||||
(* Setup callbacks. *)
|
||||
ignore (window#connect#destroy (wakeup wakener));
|
||||
ignore (menu_quit#connect#activate (wakeup wakener));
|
||||
ignore (menu_connect#connect#activate (fun () -> connect view));
|
||||
ignore (entry#connect#activate (fun () -> write view entry));
|
||||
ignore (send#connect#clicked (fun () -> write view entry));
|
||||
|
||||
window#show ();
|
||||
|
||||
(* Wait for the main window to be closed. *)
|
||||
waiter
|
|
@ -0,0 +1,62 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Program Logging
|
||||
* Copyright (C) 2011 Jérémie Dimino
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
(* This example illustrate the use of the Lwt_log module from
|
||||
lwt.unix. *)
|
||||
|
||||
(* The logging section for this module: *)
|
||||
let section = Lwt_log.Section.make "test"
|
||||
|
||||
lwt () =
|
||||
(* Enable all logging levels superior from [Info] to [Fatal]: *)
|
||||
Lwt_log.Section.set_level section Lwt_log.Info;
|
||||
|
||||
(* A message with the default logger: *)
|
||||
lwt () = Lwt_log.log ~section ~level:Lwt_log.Info "this message will appear only on stderr" in
|
||||
|
||||
(* Same as begore, but using [Lwt_log.info]: *)
|
||||
lwt () = Lwt_log.info ~section "this one too" in
|
||||
|
||||
(* A message to a custom logger, logging simultaneously to [stderr]
|
||||
and to the system logger daemon: *)
|
||||
let logger =
|
||||
Lwt_log.broadcast
|
||||
[Lwt_log.channel ~close_mode:`Keep ~channel:Lwt_io.stderr ();
|
||||
Lwt_log.syslog ~facility:`User ()]
|
||||
in
|
||||
lwt () = Lwt_log.info ~section ~logger "this message will appear on stderr and in '/var/log/user.log'" in
|
||||
|
||||
(* Logging of exceptions: *)
|
||||
Printexc.record_backtrace true;
|
||||
let f () : unit = raise Exit in
|
||||
let g () = f () in
|
||||
let h () = g () in
|
||||
lwt () =
|
||||
try
|
||||
h ();
|
||||
Lwt.return ()
|
||||
with exn ->
|
||||
Lwt_log.error ~section ~exn "h failed with"
|
||||
in
|
||||
|
||||
let logger = Lwt_log.channel ~template:"$(name): $(section): $(loc-file): $(loc-line): $(loc-column): $(message)" ~close_mode:`Keep ~channel:Lwt_io.stderr () in
|
||||
Lwt_log.info ~section ~logger "this message will appear with a location"
|
|
@ -0,0 +1,57 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Program Parallelize
|
||||
* Copyright (C) 2011 Jérémie Dimino
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
(* Reads commands from standard input and launch them in parallel,
|
||||
using as many processes as the number of CPUs. *)
|
||||
|
||||
open Lwt
|
||||
|
||||
(* Reads one command, launch it and waits for when it termination,
|
||||
then start again: *)
|
||||
let rec launch () =
|
||||
match_lwt Lwt_io.read_line_opt Lwt_io.stdin with
|
||||
| None ->
|
||||
return ()
|
||||
| Some line ->
|
||||
lwt exit_status = Lwt_process.exec (Lwt_process.shell line) in
|
||||
launch ()
|
||||
|
||||
(* Creates the initial <N> threads, where <N> is the number of
|
||||
CPUs: *)
|
||||
let rec create_threads = function
|
||||
| 0 ->
|
||||
return ()
|
||||
| n ->
|
||||
launch () <&> create_threads (n - 1)
|
||||
|
||||
(* Counts the number of CPUs using "/proc/cpuinfo": *)
|
||||
let cpus_count () =
|
||||
Lwt_stream.fold (fun _ n -> succ n)
|
||||
(Lwt_stream.filter
|
||||
(fun line ->
|
||||
try
|
||||
Scanf.sscanf line "processor :" true
|
||||
with _ ->
|
||||
false)
|
||||
(Lwt_io.lines_of_file "/proc/cpuinfo")) 0
|
||||
|
||||
lwt () = cpus_count () >>= create_threads
|
|
@ -0,0 +1,156 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Program Relay
|
||||
* Copyright (C) 2011 Jérémie Dimino
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
(* Relay data from an address to another. *)
|
||||
|
||||
open Lwt
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Relaying |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
(* Write exactly [len] bytes from [buf] at [ofs]. *)
|
||||
let rec write_exactly fd buf ofs len =
|
||||
lwt n = Lwt_bytes.write fd buf ofs len in
|
||||
if n = len then
|
||||
(* Everything has been written, do nothing. *)
|
||||
return ()
|
||||
else
|
||||
(* Write remaining data. *)
|
||||
write_exactly fd buf (ofs + n) (len - n)
|
||||
|
||||
(* Copy continously data from [in_fd] to [out_fd]. *)
|
||||
let relay in_fd out_fd =
|
||||
(* Queue of data received but not yet written. *)
|
||||
let queue = Queue.create () in
|
||||
|
||||
(* Condition used to signal the writer that some data are
|
||||
available. *)
|
||||
let cond = Lwt_condition.create () in
|
||||
|
||||
(* Boolean which tells whether the input socket has been closed. *)
|
||||
let end_of_input = ref false in
|
||||
|
||||
(* Write continously data received to [out_fd]. *)
|
||||
let rec loop_write () =
|
||||
if Queue.is_empty queue then
|
||||
if !end_of_input then
|
||||
(* End of input reached, exit. *)
|
||||
return ()
|
||||
else
|
||||
(* There is no data pending, wait for some. *)
|
||||
lwt () = Lwt_condition.wait cond in
|
||||
loop_write ()
|
||||
else
|
||||
let (buf, len) = Queue.take queue in
|
||||
lwt () = write_exactly out_fd buf 0 len in
|
||||
loop_write ()
|
||||
in
|
||||
|
||||
(* Start the writer. *)
|
||||
let writer = loop_write () in
|
||||
|
||||
(* Read continously from [in_fd]. *)
|
||||
let rec loop_read () =
|
||||
let buf = Lwt_bytes.create 8192 in
|
||||
match_lwt Lwt_bytes.read in_fd buf 0 8192 with
|
||||
| 0 ->
|
||||
(* If we read nothing, this means that the connection has
|
||||
been closed. *)
|
||||
(* Mark the end of input has reached. *)
|
||||
end_of_input := true;
|
||||
(* Singal the writer in case it is waiting for data. *)
|
||||
Lwt_condition.signal cond ();
|
||||
(* Wait for it to terminate. *)
|
||||
writer
|
||||
| n ->
|
||||
(* Otherwise, send data to the writer. *)
|
||||
Queue.add (buf, n) queue;
|
||||
(* Singal the writer in case it is waiting for data. *)
|
||||
Lwt_condition.signal cond ();
|
||||
loop_read ()
|
||||
in
|
||||
|
||||
(* Wait for either the reader to terminate or the writer to fail. *)
|
||||
pick [writer; loop_read ()]
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Entry point |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let usage () =
|
||||
prerr_endline "usage: relay <source-address>:<source-port> <destination-address>:<destination-port>";
|
||||
exit 2
|
||||
|
||||
(* Convert a string of the form "<host>:<port>" to an internet address
|
||||
object. *)
|
||||
let addr_of_string str =
|
||||
(* Split the host and the port. *)
|
||||
let idx = try String.index str ':' with Not_found -> usage () in
|
||||
let host = String.sub str 0 idx and port = String.sub str (idx + 1) (String.length str - idx - 1) in
|
||||
(* Parse the port. *)
|
||||
let port = try int_of_string port with Failure _ -> usage () in
|
||||
(* Request the address of the host. *)
|
||||
lwt entry = Lwt_unix.gethostbyname host in
|
||||
if Array.length entry.Unix.h_addr_list = 0 then begin
|
||||
Printf.eprintf "no address found for host %S\n" host;
|
||||
exit 1
|
||||
end;
|
||||
return (Unix.ADDR_INET (entry.Unix.h_addr_list.(0), port))
|
||||
|
||||
lwt () =
|
||||
if Array.length Sys.argv <> 3 then usage ();
|
||||
|
||||
try_lwt
|
||||
(* Resolve addresses. *)
|
||||
lwt src_addr = addr_of_string Sys.argv.(1) and dst_addr = addr_of_string Sys.argv.(2) in
|
||||
|
||||
(* Initialize the listening address. *)
|
||||
let sock = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
|
||||
Lwt_unix.setsockopt sock Unix.SO_REUSEADDR true;
|
||||
Lwt_unix.bind sock src_addr;
|
||||
Lwt_unix.listen sock 1024;
|
||||
|
||||
ignore (Lwt_log.notice "waiting for connection");
|
||||
|
||||
(* Wait for a connection. *)
|
||||
lwt fd1, _ = Lwt_unix.accept sock in
|
||||
|
||||
ignore (Lwt_log.notice "connection received, start relayling");
|
||||
|
||||
(* Closes the no-more used listening socket. *)
|
||||
lwt () = Lwt_unix.close sock in
|
||||
|
||||
(* Connect to the destination port. *)
|
||||
let fd2 = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
|
||||
lwt () = Lwt_unix.connect fd2 dst_addr in
|
||||
|
||||
(* Start relaying. *)
|
||||
lwt () = pick [relay fd1 fd2; relay fd2 fd1] in
|
||||
|
||||
ignore (Lwt_log.notice "done relayling");
|
||||
|
||||
return ()
|
||||
|
||||
with exn ->
|
||||
ignore (Lwt_log.error ~exn "something went wrong");
|
||||
exit 1
|
|
@ -0,0 +1,40 @@
|
|||
# OASIS_START
|
||||
# DO NOT EDIT (digest: 11d6fd54a0a3f207d6602a7b1da2317e)
|
||||
src/core/Lwt_condition
|
||||
src/core/Lwt_list
|
||||
src/core/Lwt
|
||||
src/core/Lwt_mutex
|
||||
src/core/Lwt_mvar
|
||||
src/core/Lwt_pool
|
||||
src/core/Lwt_sequence
|
||||
src/core/Lwt_stream
|
||||
src/core/Lwt_switch
|
||||
src/core/Lwt_util
|
||||
src/core/Lwt_pqueue
|
||||
src/extra/Lwt_lib
|
||||
src/glib/Lwt_glib
|
||||
src/preemptive/Lwt_preemptive
|
||||
src/react/Lwt_event
|
||||
src/react/Lwt_signal
|
||||
src/react/Lwt_react
|
||||
src/ssl/Lwt_ssl
|
||||
src/text/Lwt_text
|
||||
src/text/Lwt_term
|
||||
src/text/Lwt_read_line
|
||||
src/top/Lwt_top
|
||||
src/unix/Lwt_chan
|
||||
src/unix/Lwt_daemon
|
||||
src/unix/Lwt_gc
|
||||
src/unix/Lwt_io
|
||||
src/unix/Lwt_log
|
||||
src/unix/Lwt_main
|
||||
src/unix/Lwt_process
|
||||
src/unix/Lwt_throttle
|
||||
src/unix/Lwt_timeout
|
||||
src/unix/Lwt_unix
|
||||
src/unix/Lwt_sys
|
||||
src/unix/Lwt_engine
|
||||
src/unix/Lwt_bytes
|
||||
syntax/Pa_lwt
|
||||
syntax/Pa_lwt_log
|
||||
# OASIS_STOP
|
|
@ -0,0 +1,20 @@
|
|||
# Makefile
|
||||
# --------
|
||||
# Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org>
|
||||
# Licence : BSD3
|
||||
#
|
||||
# This file is a part of lwt.
|
||||
|
||||
all: manual.pdf
|
||||
|
||||
manual-wiki.tex: manual.wiki
|
||||
latex_of_wiki < manual.wiki > manual-wiki.tex
|
||||
|
||||
manual.pdf: manual.tex manual-wiki.tex
|
||||
rubber --pdf manual.tex
|
||||
|
||||
clean-aux:
|
||||
rm -f .latex_of_wiki_offsets *.log *.aux *.out *.toc
|
||||
|
||||
clean: clean-aux
|
||||
rm -f manual.pdf manual-wiki.tex
|
File diff suppressed because it is too large
Load Diff
Binary file not shown.
|
@ -0,0 +1,52 @@
|
|||
\documentclass{article}
|
||||
\usepackage{fullpage}
|
||||
\usepackage[utf8]{inputenc}
|
||||
\usepackage{url}
|
||||
\usepackage{hyperref}
|
||||
\usepackage{listings}
|
||||
\usepackage{xcolor}
|
||||
|
||||
\hypersetup{%
|
||||
a4paper=true,
|
||||
pdfstartview=FitH,
|
||||
colorlinks=false,
|
||||
pdfborder=0 0 0,
|
||||
pdftitle = {Lwt user manual},
|
||||
pdfauthor = {Jérémie Dimino},
|
||||
pdfkeywords = {OCaml, Lwt, Cooperative threads, Coroutines}
|
||||
}
|
||||
|
||||
\lstset{
|
||||
language=[Objective]Caml,
|
||||
extendedchars,
|
||||
showspaces=false,
|
||||
showstringspaces=false,
|
||||
showtabs=false,
|
||||
basicstyle=\ttfamily,
|
||||
frame=l,
|
||||
framerule=1.5mm,
|
||||
xleftmargin=6mm,
|
||||
framesep=4mm,
|
||||
rulecolor=\color{lightgray},
|
||||
emph={lwt,for\_lwt,try\_lwt,raise\_lwt},
|
||||
emphstyle=\color[rgb]{0.627451, 0.125490, 0.941176},
|
||||
moredelim=*[s][\itshape]{(*}{*)},
|
||||
moredelim=[is][\textcolor{darkgray}]{§}{§},
|
||||
escapechar=°,
|
||||
keywordstyle=\color[rgb]{0.627451, 0.125490, 0.941176},
|
||||
stringstyle=\color[rgb]{0.545098, 0.278431, 0.364706},
|
||||
commentstyle=\color[rgb]{0.698039, 0.133333, 0.133333},
|
||||
numberstyle=\color[rgb]{0.372549, 0.619608, 0.627451}
|
||||
}
|
||||
|
||||
\title{Lwt user manual}
|
||||
\author{Jérémie Dimino}
|
||||
|
||||
\begin{document}
|
||||
|
||||
\maketitle
|
||||
\tableofcontents
|
||||
|
||||
\include{manual-wiki}
|
||||
|
||||
\end{document}
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,2 @@
|
|||
= Lwt
|
||||
==[[manual|Overview]]
|
|
@ -0,0 +1,771 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Module Myocamlbuild
|
||||
* Copyright (C) 2010 Jérémie Dimino
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
(* Keep that in sync with the list in discover.ml *)
|
||||
let search_paths = [
|
||||
"/usr";
|
||||
"/usr/local";
|
||||
"/opt";
|
||||
"/opt/local";
|
||||
"/sw";
|
||||
"/mingw";
|
||||
]
|
||||
|
||||
(* OASIS_START *)
|
||||
(* DO NOT EDIT (digest: 4c177063a31680580ca13639e7a11972) *)
|
||||
module OASISGettext = struct
|
||||
# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISGettext.ml"
|
||||
|
||||
let ns_ str =
|
||||
str
|
||||
|
||||
let s_ str =
|
||||
str
|
||||
|
||||
let f_ (str : ('a, 'b, 'c, 'd) format4) =
|
||||
str
|
||||
|
||||
let fn_ fmt1 fmt2 n =
|
||||
if n = 1 then
|
||||
fmt1^^""
|
||||
else
|
||||
fmt2^^""
|
||||
|
||||
let init =
|
||||
[]
|
||||
|
||||
end
|
||||
|
||||
module OASISExpr = struct
|
||||
# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISExpr.ml"
|
||||
|
||||
|
||||
|
||||
open OASISGettext
|
||||
|
||||
type test = string
|
||||
|
||||
type flag = string
|
||||
|
||||
type t =
|
||||
| EBool of bool
|
||||
| ENot of t
|
||||
| EAnd of t * t
|
||||
| EOr of t * t
|
||||
| EFlag of flag
|
||||
| ETest of test * string
|
||||
|
||||
|
||||
type 'a choices = (t * 'a) list
|
||||
|
||||
let eval var_get t =
|
||||
let rec eval' =
|
||||
function
|
||||
| EBool b ->
|
||||
b
|
||||
|
||||
| ENot e ->
|
||||
not (eval' e)
|
||||
|
||||
| EAnd (e1, e2) ->
|
||||
(eval' e1) && (eval' e2)
|
||||
|
||||
| EOr (e1, e2) ->
|
||||
(eval' e1) || (eval' e2)
|
||||
|
||||
| EFlag nm ->
|
||||
let v =
|
||||
var_get nm
|
||||
in
|
||||
assert(v = "true" || v = "false");
|
||||
(v = "true")
|
||||
|
||||
| ETest (nm, vl) ->
|
||||
let v =
|
||||
var_get nm
|
||||
in
|
||||
(v = vl)
|
||||
in
|
||||
eval' t
|
||||
|
||||
let choose ?printer ?name var_get lst =
|
||||
let rec choose_aux =
|
||||
function
|
||||
| (cond, vl) :: tl ->
|
||||
if eval var_get cond then
|
||||
vl
|
||||
else
|
||||
choose_aux tl
|
||||
| [] ->
|
||||
let str_lst =
|
||||
if lst = [] then
|
||||
s_ "<empty>"
|
||||
else
|
||||
String.concat
|
||||
(s_ ", ")
|
||||
(List.map
|
||||
(fun (cond, vl) ->
|
||||
match printer with
|
||||
| Some p -> p vl
|
||||
| None -> s_ "<no printer>")
|
||||
lst)
|
||||
in
|
||||
match name with
|
||||
| Some nm ->
|
||||
failwith
|
||||
(Printf.sprintf
|
||||
(f_ "No result for the choice list '%s': %s")
|
||||
nm str_lst)
|
||||
| None ->
|
||||
failwith
|
||||
(Printf.sprintf
|
||||
(f_ "No result for a choice list: %s")
|
||||
str_lst)
|
||||
in
|
||||
choose_aux (List.rev lst)
|
||||
|
||||
end
|
||||
|
||||
|
||||
module BaseEnvLight = struct
|
||||
# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseEnvLight.ml"
|
||||
|
||||
module MapString = Map.Make(String)
|
||||
|
||||
type t = string MapString.t
|
||||
|
||||
let default_filename =
|
||||
Filename.concat
|
||||
(Sys.getcwd ())
|
||||
"setup.data"
|
||||
|
||||
let load ?(allow_empty=false) ?(filename=default_filename) () =
|
||||
if Sys.file_exists filename then
|
||||
begin
|
||||
let chn =
|
||||
open_in_bin filename
|
||||
in
|
||||
let st =
|
||||
Stream.of_channel chn
|
||||
in
|
||||
let line =
|
||||
ref 1
|
||||
in
|
||||
let st_line =
|
||||
Stream.from
|
||||
(fun _ ->
|
||||
try
|
||||
match Stream.next st with
|
||||
| '\n' -> incr line; Some '\n'
|
||||
| c -> Some c
|
||||
with Stream.Failure -> None)
|
||||
in
|
||||
let lexer =
|
||||
Genlex.make_lexer ["="] st_line
|
||||
in
|
||||
let rec read_file mp =
|
||||
match Stream.npeek 3 lexer with
|
||||
| [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] ->
|
||||
Stream.junk lexer;
|
||||
Stream.junk lexer;
|
||||
Stream.junk lexer;
|
||||
read_file (MapString.add nm value mp)
|
||||
| [] ->
|
||||
mp
|
||||
| _ ->
|
||||
failwith
|
||||
(Printf.sprintf
|
||||
"Malformed data file '%s' line %d"
|
||||
filename !line)
|
||||
in
|
||||
let mp =
|
||||
read_file MapString.empty
|
||||
in
|
||||
close_in chn;
|
||||
mp
|
||||
end
|
||||
else if allow_empty then
|
||||
begin
|
||||
MapString.empty
|
||||
end
|
||||
else
|
||||
begin
|
||||
failwith
|
||||
(Printf.sprintf
|
||||
"Unable to load environment, the file '%s' doesn't exist."
|
||||
filename)
|
||||
end
|
||||
|
||||
let var_get name env =
|
||||
let rec var_expand str =
|
||||
let buff =
|
||||
Buffer.create ((String.length str) * 2)
|
||||
in
|
||||
Buffer.add_substitute
|
||||
buff
|
||||
(fun var ->
|
||||
try
|
||||
var_expand (MapString.find var env)
|
||||
with Not_found ->
|
||||
failwith
|
||||
(Printf.sprintf
|
||||
"No variable %s defined when trying to expand %S."
|
||||
var
|
||||
str))
|
||||
str;
|
||||
Buffer.contents buff
|
||||
in
|
||||
var_expand (MapString.find name env)
|
||||
|
||||
let var_choose lst env =
|
||||
OASISExpr.choose
|
||||
(fun nm -> var_get nm env)
|
||||
lst
|
||||
end
|
||||
|
||||
|
||||
module MyOCamlbuildFindlib = struct
|
||||
# 21 "/home/chambart/bordel/oasis/oasis/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml"
|
||||
|
||||
(** OCamlbuild extension, copied from
|
||||
* http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild
|
||||
* by N. Pouillard and others
|
||||
*
|
||||
* Updated on 2009/02/28
|
||||
*
|
||||
* Modified by Sylvain Le Gall
|
||||
*)
|
||||
open Ocamlbuild_plugin
|
||||
|
||||
(* these functions are not really officially exported *)
|
||||
let run_and_read =
|
||||
Ocamlbuild_pack.My_unix.run_and_read
|
||||
|
||||
let blank_sep_strings =
|
||||
Ocamlbuild_pack.Lexers.blank_sep_strings
|
||||
|
||||
let split s ch =
|
||||
let x =
|
||||
ref []
|
||||
in
|
||||
let rec go s =
|
||||
let pos =
|
||||
String.index s ch
|
||||
in
|
||||
x := (String.before s pos)::!x;
|
||||
go (String.after s (pos + 1))
|
||||
in
|
||||
try
|
||||
go s
|
||||
with Not_found -> !x
|
||||
|
||||
let split_nl s = split s '\n'
|
||||
|
||||
let before_space s =
|
||||
try
|
||||
String.before s (String.index s ' ')
|
||||
with Not_found -> s
|
||||
|
||||
(* this lists all supported packages *)
|
||||
let find_packages () =
|
||||
List.map before_space (split_nl & run_and_read "ocamlfind list")
|
||||
|
||||
(* this is supposed to list available syntaxes, but I don't know how to do it. *)
|
||||
let find_syntaxes () = ["camlp4o"; "camlp4r"]
|
||||
|
||||
(* ocamlfind command *)
|
||||
let ocamlfind x = S[A"ocamlfind"; x]
|
||||
|
||||
let dispatch =
|
||||
function
|
||||
| Before_options ->
|
||||
(* by using Before_options one let command line options have an higher priority *)
|
||||
(* on the contrary using After_options will guarantee to have the higher priority *)
|
||||
(* override default commands by ocamlfind ones *)
|
||||
Options.ocamlc := ocamlfind & A"ocamlc";
|
||||
Options.ocamlopt := ocamlfind & A"ocamlopt";
|
||||
Options.ocamldep := ocamlfind & A"ocamldep";
|
||||
Options.ocamldoc := ocamlfind & A"ocamldoc";
|
||||
Options.ocamlmktop := ocamlfind & A"ocamlmktop"
|
||||
|
||||
| After_rules ->
|
||||
|
||||
(* When one link an OCaml library/binary/package, one should use -linkpkg *)
|
||||
flag ["ocaml"; "link"; "program"] & A"-linkpkg";
|
||||
|
||||
(* For each ocamlfind package one inject the -package option when
|
||||
* compiling, computing dependencies, generating documentation and
|
||||
* linking. *)
|
||||
List.iter
|
||||
begin fun pkg ->
|
||||
flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg];
|
||||
flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg];
|
||||
flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg];
|
||||
flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg];
|
||||
flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S[A"-package"; A pkg];
|
||||
end
|
||||
(find_packages ());
|
||||
|
||||
(* Like -package but for extensions syntax. Morover -syntax is useless
|
||||
* when linking. *)
|
||||
List.iter begin fun syntax ->
|
||||
flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
|
||||
flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
|
||||
flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
|
||||
flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
|
||||
end (find_syntaxes ());
|
||||
|
||||
(* The default "thread" tag is not compatible with ocamlfind.
|
||||
* Indeed, the default rules add the "threads.cma" or "threads.cmxa"
|
||||
* options when using this tag. When using the "-linkpkg" option with
|
||||
* ocamlfind, this module will then be added twice on the command line.
|
||||
*
|
||||
* To solve this, one approach is to add the "-thread" option when using
|
||||
* the "threads" package using the previous plugin.
|
||||
*)
|
||||
flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]);
|
||||
flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]);
|
||||
flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"])
|
||||
|
||||
| _ ->
|
||||
()
|
||||
|
||||
end
|
||||
|
||||
module MyOCamlbuildBase = struct
|
||||
# 21 "/home/chambart/bordel/oasis/oasis/src/plugins/ocamlbuild/MyOCamlbuildBase.ml"
|
||||
|
||||
(** Base functions for writing myocamlbuild.ml
|
||||
@author Sylvain Le Gall
|
||||
*)
|
||||
|
||||
|
||||
|
||||
open Ocamlbuild_plugin
|
||||
|
||||
type dir = string
|
||||
type file = string
|
||||
type name = string
|
||||
type tag = string
|
||||
|
||||
# 55 "/home/chambart/bordel/oasis/oasis/src/plugins/ocamlbuild/MyOCamlbuildBase.ml"
|
||||
|
||||
type t =
|
||||
{
|
||||
lib_ocaml: (name * dir list) list;
|
||||
lib_c: (name * dir * file list) list;
|
||||
flags: (tag list * (spec OASISExpr.choices)) list;
|
||||
}
|
||||
|
||||
let env_filename =
|
||||
Pathname.basename
|
||||
BaseEnvLight.default_filename
|
||||
|
||||
let dispatch_combine lst =
|
||||
fun e ->
|
||||
List.iter
|
||||
(fun dispatch -> dispatch e)
|
||||
lst
|
||||
|
||||
let dispatch t e =
|
||||
let env =
|
||||
BaseEnvLight.load
|
||||
~filename:env_filename
|
||||
~allow_empty:true
|
||||
()
|
||||
in
|
||||
match e with
|
||||
| Before_options ->
|
||||
let no_trailing_dot s =
|
||||
if String.length s >= 1 && s.[0] = '.' then
|
||||
String.sub s 1 ((String.length s) - 1)
|
||||
else
|
||||
s
|
||||
in
|
||||
List.iter
|
||||
(fun (opt, var) ->
|
||||
try
|
||||
opt := no_trailing_dot (BaseEnvLight.var_get var env)
|
||||
with Not_found ->
|
||||
Printf.eprintf "W: Cannot get variable %s" var)
|
||||
[
|
||||
Options.ext_obj, "ext_obj";
|
||||
Options.ext_lib, "ext_lib";
|
||||
Options.ext_dll, "ext_dll";
|
||||
]
|
||||
|
||||
| After_rules ->
|
||||
(* Declare OCaml libraries *)
|
||||
List.iter
|
||||
(function
|
||||
| lib, [] ->
|
||||
ocaml_lib lib;
|
||||
| lib, dir :: tl ->
|
||||
ocaml_lib ~dir:dir lib;
|
||||
List.iter
|
||||
(fun dir ->
|
||||
flag
|
||||
["ocaml"; "use_"^lib; "compile"]
|
||||
(S[A"-I"; P dir]))
|
||||
tl)
|
||||
t.lib_ocaml;
|
||||
|
||||
(* Declare C libraries *)
|
||||
List.iter
|
||||
(fun (lib, dir, headers) ->
|
||||
(* Handle C part of library *)
|
||||
flag ["link"; "library"; "ocaml"; "byte"; "use_lib"^lib]
|
||||
(S[A"-dllib"; A("-l"^lib); A"-cclib"; A("-l"^lib)]);
|
||||
|
||||
flag ["link"; "library"; "ocaml"; "native"; "use_lib"^lib]
|
||||
(S[A"-cclib"; A("-l"^lib)]);
|
||||
|
||||
flag ["link"; "program"; "ocaml"; "byte"; "use_lib"^lib]
|
||||
(S[A"-dllib"; A("dll"^lib)]);
|
||||
|
||||
(* When ocaml link something that use the C library, then one
|
||||
need that file to be up to date.
|
||||
*)
|
||||
dep ["link"; "ocaml"; "use_lib"^lib]
|
||||
[dir/"lib"^lib^"."^(!Options.ext_lib)];
|
||||
|
||||
(* TODO: be more specific about what depends on headers *)
|
||||
(* Depends on .h files *)
|
||||
dep ["compile"; "c"]
|
||||
headers;
|
||||
|
||||
(* Setup search path for lib *)
|
||||
flag ["link"; "ocaml"; "use_"^lib]
|
||||
(S[A"-I"; P(dir)]);
|
||||
)
|
||||
t.lib_c;
|
||||
|
||||
(* Add flags *)
|
||||
List.iter
|
||||
(fun (tags, cond_specs) ->
|
||||
let spec =
|
||||
BaseEnvLight.var_choose cond_specs env
|
||||
in
|
||||
flag tags & spec)
|
||||
t.flags
|
||||
| _ ->
|
||||
()
|
||||
|
||||
let dispatch_default t =
|
||||
dispatch_combine
|
||||
[
|
||||
dispatch t;
|
||||
MyOCamlbuildFindlib.dispatch;
|
||||
]
|
||||
|
||||
end
|
||||
|
||||
|
||||
open Ocamlbuild_plugin;;
|
||||
let package_default =
|
||||
{
|
||||
MyOCamlbuildBase.lib_ocaml =
|
||||
[
|
||||
("src/core/lwt", ["src/core"]);
|
||||
("src/unix/lwt-unix", ["src/unix"]);
|
||||
("src/react/lwt-react", ["src/react"]);
|
||||
("tests/test", ["tests"]);
|
||||
("src/text/lwt-text", ["src/text"]);
|
||||
("syntax/lwt-syntax", ["syntax"]);
|
||||
("src/top/lwt-top", ["src/top"]);
|
||||
("src/preemptive/lwt-preemptive", ["src/preemptive"]);
|
||||
("src/simple_top/lwt-simple-top", ["src/simple_top"]);
|
||||
("src/glib/lwt-glib", ["src/glib"]);
|
||||
("syntax/lwt-syntax-log", ["syntax"]);
|
||||
("src/extra/lwt-extra", ["src/extra"]);
|
||||
("syntax/optcomp", ["syntax"]);
|
||||
("syntax/lwt-syntax-options", ["syntax"]);
|
||||
("src/ssl/lwt-ssl", ["src/ssl"])
|
||||
];
|
||||
lib_c =
|
||||
[
|
||||
("lwt-unix",
|
||||
"src/unix",
|
||||
["src/unix/lwt_config.h"; "src/unix/lwt_unix.h"]);
|
||||
("lwt-text", "src/text", []);
|
||||
("lwt-glib", "src/glib", [])
|
||||
];
|
||||
flags =
|
||||
[
|
||||
(["oasis_library_lwt_unix_cclib"; "link"],
|
||||
[
|
||||
(OASISExpr.EBool true, S []);
|
||||
(OASISExpr.EFlag "libev", S [A "-cclib"; A "-lev"]);
|
||||
(OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32")),
|
||||
S [A "-cclib"; A "-lpthread"]);
|
||||
(OASISExpr.EAnd
|
||||
(OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32")),
|
||||
OASISExpr.EFlag "libev"),
|
||||
S [A "-cclib"; A "-lpthread"; A "-cclib"; A "-lev"]);
|
||||
(OASISExpr.ETest ("os_type", "Win32"),
|
||||
S [A "-cclib"; A "ws2_32.lib"]);
|
||||
(OASISExpr.EAnd
|
||||
(OASISExpr.ETest ("os_type", "Win32"),
|
||||
OASISExpr.EFlag "libev"),
|
||||
S [A "-cclib"; A "ws2_32.lib"; A "-cclib"; A "-lev"]);
|
||||
(OASISExpr.EAnd
|
||||
(OASISExpr.ETest ("os_type", "Win32"),
|
||||
OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32"))),
|
||||
S [A "-cclib"; A "ws2_32.lib"; A "-cclib"; A "-lpthread"]);
|
||||
(OASISExpr.EAnd
|
||||
(OASISExpr.EAnd
|
||||
(OASISExpr.ETest ("os_type", "Win32"),
|
||||
OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32"))),
|
||||
OASISExpr.EFlag "libev"),
|
||||
S
|
||||
[
|
||||
A "-cclib";
|
||||
A "ws2_32.lib";
|
||||
A "-cclib";
|
||||
A "-lpthread";
|
||||
A "-cclib";
|
||||
A "-lev"
|
||||
])
|
||||
]);
|
||||
(["oasis_library_lwt_unix_cclib"; "ocamlmklib"; "c"],
|
||||
[
|
||||
(OASISExpr.EBool true, S []);
|
||||
(OASISExpr.EFlag "libev", S [A "-lev"]);
|
||||
(OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32")),
|
||||
S [A "-lpthread"]);
|
||||
(OASISExpr.EAnd
|
||||
(OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32")),
|
||||
OASISExpr.EFlag "libev"),
|
||||
S [A "-lpthread"; A "-lev"]);
|
||||
(OASISExpr.ETest ("os_type", "Win32"), S [A "ws2_32.lib"]);
|
||||
(OASISExpr.EAnd
|
||||
(OASISExpr.ETest ("os_type", "Win32"),
|
||||
OASISExpr.EFlag "libev"),
|
||||
S [A "ws2_32.lib"; A "-lev"]);
|
||||
(OASISExpr.EAnd
|
||||
(OASISExpr.ETest ("os_type", "Win32"),
|
||||
OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32"))),
|
||||
S [A "ws2_32.lib"; A "-lpthread"]);
|
||||
(OASISExpr.EAnd
|
||||
(OASISExpr.EAnd
|
||||
(OASISExpr.ETest ("os_type", "Win32"),
|
||||
OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32"))),
|
||||
OASISExpr.EFlag "libev"),
|
||||
S [A "ws2_32.lib"; A "-lpthread"; A "-lev"])
|
||||
])
|
||||
];
|
||||
}
|
||||
;;
|
||||
|
||||
let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;;
|
||||
|
||||
(* OASIS_STOP *)
|
||||
|
||||
open Ocamlbuild_plugin
|
||||
|
||||
let pkg_config flags =
|
||||
with_temp_file "lwt" "pkg-config"
|
||||
(fun tmp ->
|
||||
Command.execute ~quiet:true & Cmd(S[A "pkg-config"; S flags; Sh ">"; A tmp]);
|
||||
List.map (fun arg -> A arg) (string_list_of_file tmp))
|
||||
|
||||
let define_c_library ?(msvc = false) ~name ~c_name () =
|
||||
let tag = Printf.sprintf "use_C_%s" name in
|
||||
|
||||
(* Get compile flags. *)
|
||||
let opt = pkg_config [A "--cflags"; A c_name] in
|
||||
|
||||
(* Get linking flags. *)
|
||||
let lib =
|
||||
if msvc then
|
||||
(* With msvc we need to pass "glib-2.0.lib" instead of
|
||||
"-lglib-2.0" otherwise executables will fail. *)
|
||||
pkg_config [A "--libs-only-L"; A c_name] @ pkg_config [A "--libs-only-l"; A "--msvc-syntax"; A c_name]
|
||||
else
|
||||
pkg_config [A "--libs"; A c_name]
|
||||
in
|
||||
|
||||
(* Add flags for linking with the C library: *)
|
||||
flag ["ocamlmklib"; "c"; tag] & S lib;
|
||||
|
||||
(* C stubs using the C library must be compiled with the library
|
||||
specifics flags: *)
|
||||
flag ["c"; "compile"; tag] & S (List.map (fun arg -> S[A"-ccopt"; arg]) opt);
|
||||
|
||||
(* OCaml libraries must depends on the C library: *)
|
||||
flag ["link"; "ocaml"; tag] & S (List.map (fun arg -> S[A"-cclib"; arg]) lib)
|
||||
|
||||
let () =
|
||||
dispatch
|
||||
(fun hook ->
|
||||
dispatch_default hook;
|
||||
match hook with
|
||||
| Before_options ->
|
||||
Options.make_links := false
|
||||
|
||||
| After_rules ->
|
||||
dep ["file:src/unix/lwt_unix_stubs.c"] ["src/unix/lwt_unix_unix.c"; "src/unix/lwt_unix_windows.c"];
|
||||
dep ["pa_optcomp"] ["src/unix/lwt_config.ml"];
|
||||
|
||||
(* Internal syntax extension *)
|
||||
List.iter
|
||||
(fun base ->
|
||||
let tag = "pa_" ^ base and file = "syntax/pa_" ^ base ^ ".cmo" in
|
||||
flag ["ocaml"; "compile"; tag] & S[A"-ppopt"; A file];
|
||||
flag ["ocaml"; "ocamldep"; tag] & S[A"-ppopt"; A file];
|
||||
flag ["ocaml"; "doc"; tag] & S[A"-ppopt"; A file];
|
||||
dep ["ocaml"; "ocamldep"; tag] [file])
|
||||
["lwt_options"; "lwt"; "lwt_log"; "optcomp"];
|
||||
|
||||
(* Optcomp for .mli *)
|
||||
flag ["ocaml"; "compile"; "pa_optcomp_standalone"] & S[A"-pp"; A "./syntax/optcomp.byte"];
|
||||
flag ["ocaml"; "ocamldep"; "pa_optcomp_standalone"] & S[A"-pp"; A "./syntax/optcomp.byte"];
|
||||
flag ["ocaml"; "doc"; "pa_optcomp_standalone"] & S[A"-pp"; A "./syntax/optcomp.byte"];
|
||||
dep ["ocaml"; "ocamldep"; "pa_optcomp_standalone"] ["syntax/optcomp.byte"];
|
||||
|
||||
(* Use an introduction page with categories *)
|
||||
tag_file "lwt-api.docdir/index.html" ["apiref"];
|
||||
dep ["apiref"] ["apiref-intro"];
|
||||
flag ["apiref"] & S[A "-intro"; P "apiref-intro"; A"-colorize-code"];
|
||||
|
||||
(* Glib bindings: *)
|
||||
let env = BaseEnvLight.load ~allow_empty:true ~filename:MyOCamlbuildBase.env_filename () in
|
||||
let msvc = BaseEnvLight.var_get "ccomp_type" env = "msvc" in
|
||||
if BaseEnvLight.var_get "glib" env = "true" || BaseEnvLight.var_get "all" env = "true" then
|
||||
define_c_library ~msvc ~name:"glib" ~c_name:"glib-2.0" ();
|
||||
|
||||
let opts = S[A "-ppopt"; A "-let"; A "-ppopt"; A ("windows=" ^ if BaseEnvLight.var_get "os_type" env <> "Unix" then "true" else "false")] in
|
||||
flag ["ocaml"; "compile"; "pa_optcomp"] & opts;
|
||||
flag ["ocaml"; "ocamldep"; "pa_optcomp"] & opts;
|
||||
(*flag ["ocaml"; "doc"; "pa_optcomp"] & opts; Does not work... *)
|
||||
|
||||
flag ["ocaml"; "link"; "toplevel"] & A"-linkpkg";
|
||||
|
||||
let env = BaseEnvLight.load () in
|
||||
let stdlib_path = BaseEnvLight.var_get "standard_library" env in
|
||||
|
||||
(* Try to find the path where compiler libraries are: *)
|
||||
let compiler_libs =
|
||||
let stdlib = String.chomp stdlib_path in
|
||||
try
|
||||
let path =
|
||||
List.find Pathname.exists [
|
||||
stdlib / "compiler-libs";
|
||||
stdlib / "compiler-lib";
|
||||
stdlib / ".." / "compiler-libs";
|
||||
stdlib / ".." / "compiler-lib";
|
||||
]
|
||||
in
|
||||
path :: List.filter Pathname.exists [ path / "typing"; path / "utils"; path / "parsing" ]
|
||||
with Not_found ->
|
||||
[]
|
||||
in
|
||||
|
||||
(* Add directories for compiler-libraries: *)
|
||||
let paths = List.map (fun path -> S[A"-I"; A path]) compiler_libs in
|
||||
List.iter
|
||||
(fun stage -> flag ["ocaml"; stage; "use_compiler_libs"] & S paths)
|
||||
["compile"; "ocamldep"; "doc"; "link"];
|
||||
|
||||
dep ["file:src/top/toplevel_temp.top"] ["src/core/lwt.cma";
|
||||
"src/react/lwt-react.cma";
|
||||
"src/unix/lwt-unix.cma";
|
||||
"src/text/lwt-text.cma";
|
||||
"src/top/lwt-top.cma"];
|
||||
|
||||
flag ["file:src/top/toplevel_temp.top"] & S[A"-I"; A"src/unix";
|
||||
A"-I"; A"src/text";
|
||||
A"src/core/lwt.cma";
|
||||
A"src/react/lwt-react.cma";
|
||||
A"src/unix/lwt-unix.cma";
|
||||
A"src/text/lwt-text.cma";
|
||||
A"src/top/lwt-top.cma"];
|
||||
|
||||
(* Expunge compiler modules *)
|
||||
rule "toplevel expunge"
|
||||
~dep:"src/top/toplevel_temp.top"
|
||||
~prod:"src/top/lwt_toplevel.byte"
|
||||
(fun _ _ ->
|
||||
let directories =
|
||||
stdlib_path
|
||||
:: "src/core"
|
||||
:: "src/react"
|
||||
:: "src/unix"
|
||||
:: "src/text"
|
||||
:: "src/top"
|
||||
:: (List.map
|
||||
(fun lib ->
|
||||
String.chomp
|
||||
(run_and_read
|
||||
("ocamlfind query " ^ lib)))
|
||||
["findlib"; "react"; "unix"; "text"])
|
||||
in
|
||||
let modules =
|
||||
List.fold_left
|
||||
(fun set directory ->
|
||||
List.fold_left
|
||||
(fun set fname ->
|
||||
if Pathname.check_extension fname "cmi" then
|
||||
StringSet.add (module_name_of_pathname fname) set
|
||||
else
|
||||
set)
|
||||
set
|
||||
(Array.to_list (Pathname.readdir directory)))
|
||||
StringSet.empty directories
|
||||
in
|
||||
Cmd(S[A(stdlib_path / "expunge");
|
||||
A"src/top/toplevel_temp.top";
|
||||
A"src/top/lwt_toplevel.byte";
|
||||
A"outcometree"; A"topdirs"; A"toploop";
|
||||
S(List.map (fun x -> A x) (StringSet.elements modules))]));
|
||||
|
||||
(* Search for a header file in standard directories. *)
|
||||
let search_header header =
|
||||
let rec loop = function
|
||||
| [] ->
|
||||
None
|
||||
| dir :: dirs ->
|
||||
if Sys.file_exists (dir ^ "/include/" ^ header) then
|
||||
Some dir
|
||||
else
|
||||
loop dirs
|
||||
in
|
||||
loop search_paths
|
||||
in
|
||||
|
||||
(* Add directories for libev and pthreads *)
|
||||
let flags dir =
|
||||
flag ["ocamlmklib"; "c"; "use_stubs"] & A("-L" ^ dir ^ "/lib");
|
||||
flag ["c"; "compile"; "use_stubs"] & S[A"-ccopt"; A("-I" ^ dir ^ "/include")];
|
||||
flag ["link"; "ocaml"; "use_stubs"] & S[A"-cclib"; A("-L" ^ dir ^ "/lib")]
|
||||
in
|
||||
begin
|
||||
match search_header "ev.h", search_header "pthread.h" with
|
||||
| None, None -> ()
|
||||
| Some path, None | None, Some path -> flags path
|
||||
| Some path1, Some path2 when path1 = path2 -> flags path1
|
||||
| Some path1, Some path2 -> flags path1; flags path2
|
||||
end
|
||||
|
||||
| _ ->
|
||||
())
|
||||
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,115 @@
|
|||
# OASIS_START
|
||||
# DO NOT EDIT (digest: 92360f3460ecb78dca24ff748f6650bd)
|
||||
version = "2.3.2"
|
||||
description = "Lightweight thread library for OCaml (core library)"
|
||||
archive(byte) = "lwt.cma"
|
||||
archive(native) = "lwt.cmxa"
|
||||
exists_if = "lwt.cma"
|
||||
package "ssl" (
|
||||
version = "2.3.2"
|
||||
description = "SSL support for Lwt"
|
||||
requires = "ssl lwt.unix"
|
||||
archive(byte) = "lwt-ssl.cma"
|
||||
archive(native) = "lwt-ssl.cmxa"
|
||||
exists_if = "lwt-ssl.cma"
|
||||
)
|
||||
|
||||
package "extra" (
|
||||
version = "2.3.2"
|
||||
description = "Unix functions for Lwt using Lwt_preemptive"
|
||||
requires = "lwt lwt.preemptive"
|
||||
archive(byte) = "lwt-extra.cma"
|
||||
archive(native) = "lwt-extra.cmxa"
|
||||
exists_if = "lwt-extra.cma"
|
||||
)
|
||||
|
||||
package "glib" (
|
||||
version = "2.3.2"
|
||||
description = "Glib integration"
|
||||
requires = "lwt lwt.unix"
|
||||
archive(byte) = "lwt-glib.cma"
|
||||
archive(native) = "lwt-glib.cmxa"
|
||||
exists_if = "lwt-glib.cma"
|
||||
)
|
||||
|
||||
package "simple-top" (
|
||||
version = "2.3.2"
|
||||
description = "Unix support for lwt"
|
||||
requires = "lwt lwt.unix"
|
||||
archive(byte) = "lwt-simple-top.cma"
|
||||
archive(native) = "lwt-simple-top.cmxa"
|
||||
exists_if = "lwt-simple-top.cma"
|
||||
)
|
||||
|
||||
package "preemptive" (
|
||||
version = "2.3.2"
|
||||
description = "Preemptive threads support for Lwt"
|
||||
requires = "lwt lwt.unix threads"
|
||||
archive(byte) = "lwt-preemptive.cma"
|
||||
archive(native) = "lwt-preemptive.cmxa"
|
||||
exists_if = "lwt-preemptive.cma"
|
||||
)
|
||||
|
||||
package "top" (
|
||||
version = "2.3.2"
|
||||
description = "Line-editing in the toplevel"
|
||||
requires = "lwt lwt.text findlib"
|
||||
archive(byte) = "lwt-top.cma"
|
||||
archive(native) = "lwt-top.cmxa"
|
||||
exists_if = "lwt-top.cma"
|
||||
)
|
||||
|
||||
package "syntax" (
|
||||
version = "2.3.2"
|
||||
description = "Syntactic sugars for Lwt"
|
||||
requires = "camlp4 lwt.syntax.options"
|
||||
archive(syntax,preprocessor) = "lwt-syntax.cma"
|
||||
archive(syntax,toploop) = "lwt-syntax.cma"
|
||||
exists_if = "lwt-syntax.cma"
|
||||
package "options" (
|
||||
version = "2.3.2"
|
||||
description = "Options for syntax extensions"
|
||||
requires = "camlp4"
|
||||
archive(syntax,preprocessor) = "lwt-syntax-options.cma"
|
||||
archive(syntax,toploop) = "lwt-syntax-options.cma"
|
||||
exists_if = "lwt-syntax-options.cma"
|
||||
)
|
||||
|
||||
package "log" (
|
||||
version = "2.3.2"
|
||||
description = "Syntactic sugars for logging"
|
||||
requires = "camlp4 lwt.syntax.options"
|
||||
archive(syntax,preprocessor) = "lwt-syntax-log.cma"
|
||||
archive(syntax,toploop) = "lwt-syntax-log.cma"
|
||||
exists_if = "lwt-syntax-log.cma"
|
||||
)
|
||||
)
|
||||
|
||||
package "text" (
|
||||
version = "2.3.2"
|
||||
description = "Text mode utilities"
|
||||
requires = "lwt lwt.unix lwt.react text text.bigarray"
|
||||
archive(byte) = "lwt-text.cma"
|
||||
archive(native) = "lwt-text.cmxa"
|
||||
exists_if = "lwt-text.cma"
|
||||
)
|
||||
|
||||
package "react" (
|
||||
version = "2.3.2"
|
||||
description = "Reactive programming helpers"
|
||||
requires = "lwt react"
|
||||
archive(byte) = "lwt-react.cma"
|
||||
archive(native) = "lwt-react.cmxa"
|
||||
exists_if = "lwt-react.cma"
|
||||
)
|
||||
|
||||
package "unix" (
|
||||
version = "2.3.2"
|
||||
description = "Unix support for lwt"
|
||||
requires = "lwt unix bigarray"
|
||||
archive(byte) = "lwt-unix.cma"
|
||||
archive(native) = "lwt-unix.cmxa"
|
||||
exists_if = "lwt-unix.cma"
|
||||
)
|
||||
# OASIS_STOP
|
||||
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,396 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Interface Lwt
|
||||
* Copyright (C) 2005-2008 Jérôme Vouillon
|
||||
* Laboratoire PPS - CNRS Université Paris Diderot
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
(** Module [Lwt]: cooperative light-weight threads. *)
|
||||
|
||||
(** This module defines {e cooperative light-weight threads} with
|
||||
their primitives. A {e light-weight thread} represent a
|
||||
computation that may be not terminated, for example because it is
|
||||
waiting for some event to happen.
|
||||
|
||||
Lwt threads are cooperative in the sense that switching to another
|
||||
thread is awlays explicit (with {!wakeup} or {!wekup_exn}). When a
|
||||
thread is running, it executes as much as possible, and then
|
||||
returns (a value or an eror) or sleeps.
|
||||
|
||||
Note that inside a Lwt thread, exceptions must be raised with
|
||||
{!fail} instead of [raise]. Also the [try ... with ...]
|
||||
construction will not catch Lwt errors. You must use {!catch}
|
||||
instead. You can also use {!wrap} for functions that may raise
|
||||
normal exception.
|
||||
|
||||
Lwt also provides the syntax extension {!Pa_lwt} to make code
|
||||
using Lwt more readable.
|
||||
*)
|
||||
|
||||
(** {6 Definitions and basics} *)
|
||||
|
||||
type +'a t
|
||||
(** The type of threads returning a result of type ['a]. *)
|
||||
|
||||
val return : 'a -> 'a t
|
||||
(** [return e] is a thread whose return value is the value of the
|
||||
expression [e]. *)
|
||||
|
||||
val fail : exn -> 'a t
|
||||
(** [fail e] is a thread that fails with the exception [e]. *)
|
||||
|
||||
val bind : 'a t -> ('a -> 'b t) -> 'b t
|
||||
(** [bind t f] is a thread which first waits for the thread [t] to
|
||||
terminate and then, if the thread succeeds, behaves as the
|
||||
application of function [f] to the return value of [t]. If the
|
||||
thread [t] fails, [bind t f] also fails, with the same
|
||||
exception.
|
||||
|
||||
The expression [bind t (fun x -> t')] can intuitively be read as
|
||||
[let x = t in t'], and if you use the {e lwt.syntax} syntax
|
||||
extension, you can write a bind operation like that: [lwt x = t in t'].
|
||||
|
||||
Note that [bind] is also often used just for synchronization
|
||||
purpose: [t'] will not execute before [t] is terminated.
|
||||
|
||||
The result of a thread can be bound several time. *)
|
||||
|
||||
val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
|
||||
(** [t >>= f] is an alternative notation for [bind t f]. *)
|
||||
|
||||
val (=<<) : ('a -> 'b t) -> 'a t -> 'b t
|
||||
(** [f =<< t] is [t >>= f] *)
|
||||
|
||||
val map : ('a -> 'b) -> 'a t -> 'b t
|
||||
(** [map f m] map the result of a thread. This is the same as [bind
|
||||
m (fun x -> return (f x))] *)
|
||||
|
||||
val (>|=) : 'a t -> ('a -> 'b) -> 'b t
|
||||
(** [m >|= f] is [map f m] *)
|
||||
|
||||
val (=|<) : ('a -> 'b) -> 'a t -> 'b t
|
||||
(** [f =|< m] is [map f m] *)
|
||||
|
||||
(** {6 Thread storage} *)
|
||||
|
||||
type 'a key
|
||||
(** Type of a key. Keys are used to store local values into
|
||||
threads *)
|
||||
|
||||
val new_key : unit -> 'a key
|
||||
(** [new_key ()] creates a new key. *)
|
||||
|
||||
val get : 'a key -> 'a option
|
||||
(** [get key] returns the value associated with [key] in the current
|
||||
thread. *)
|
||||
|
||||
val with_value : 'a key -> 'a option -> (unit -> 'b) -> 'b
|
||||
(** [with_value key value f] executes [f] with [value] associated to
|
||||
[key]. The previous value associated to [key] is restored after
|
||||
[f] terminates. *)
|
||||
|
||||
(** {6 Exceptions handling} *)
|
||||
|
||||
val catch : (unit -> 'a t) -> (exn -> 'a t) -> 'a t
|
||||
(** [catch t f] is a thread that behaves as the thread [t ()] if
|
||||
this thread succeeds. If the thread [t ()] fails with some
|
||||
exception, [catch t f] behaves as the application of [f] to this
|
||||
exception. *)
|
||||
|
||||
val try_bind : (unit -> 'a t) -> ('a -> 'b t) -> (exn -> 'b t) -> 'b t
|
||||
(** [try_bind t f g] behaves as [bind (t ()) f] if [t] does not
|
||||
fail. Otherwise, it behaves as the application of [g] to the
|
||||
exception associated to [t ()]. *)
|
||||
|
||||
val finalize : (unit -> 'a t) -> (unit -> unit t) -> 'a t
|
||||
(** [finalize f g] returns the same result as [f ()] whether it
|
||||
fails or not. In both cases, [g ()] is executed after [f]. *)
|
||||
|
||||
val wrap : (unit -> 'a) -> 'a t
|
||||
(** [wrap f] calls [f] and transform the result into a monad. If [f]
|
||||
raise an exception, it is catched by Lwt.
|
||||
|
||||
This is actually the same as:
|
||||
|
||||
{[
|
||||
try
|
||||
return (f ())
|
||||
with exn ->
|
||||
fail exn
|
||||
]}
|
||||
*)
|
||||
|
||||
val wrap1 : ('a -> 'b) -> 'a -> 'b t
|
||||
(** [wrap1 f x] applies [f] on [x] and returns the result as a
|
||||
thread. If the application of [f] to [x] raise an exception it
|
||||
is catched and a thread is returned.
|
||||
|
||||
Note that you must use {!wrap} instead of {!wrap1} if the
|
||||
evaluation of [x] may raise an exception.
|
||||
|
||||
for example the following code is not ok:
|
||||
|
||||
{[
|
||||
wrap1 f (Hashtbl.find table key)
|
||||
]}
|
||||
|
||||
you should write instead:
|
||||
|
||||
{[
|
||||
wrap (fun () -> f (Hashtbl.find table key))
|
||||
]}
|
||||
*)
|
||||
|
||||
val wrap2 : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c t
|
||||
val wrap3 : ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd t
|
||||
val wrap4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a -> 'b -> 'c -> 'd -> 'e t
|
||||
val wrap5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f t
|
||||
val wrap6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g t
|
||||
val wrap7 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h t
|
||||
|
||||
(** {6 Multi-threads composition} *)
|
||||
|
||||
val choose : 'a t list -> 'a t
|
||||
(** [choose l] behaves as the first thread in [l] to terminate. If
|
||||
several threads are already terminated, one is choosen at
|
||||
random.
|
||||
|
||||
Note: {!choose} leaves the local values of the current thread
|
||||
unchanged. *)
|
||||
|
||||
val nchoose : 'a t list -> 'a list t
|
||||
(** [nchoose l] returns the value of all that have succcessfully
|
||||
terminated. If all threads are sleeping, it waits for at least
|
||||
one to terminates. If one the threads of [l] fails, [nchoose]
|
||||
fails with the same exception.
|
||||
|
||||
Note: {!nchoose} leaves the local values of the current thread
|
||||
unchanged. *)
|
||||
|
||||
val nchoose_split : 'a t list -> ('a list * 'a t list) t
|
||||
(** [nchoose_split l] does the same as {!nchoose} but also retrurns
|
||||
the list of threads that have not yet terminated. *)
|
||||
|
||||
val join : unit t list -> unit t
|
||||
(** [join l] waits for all threads in [l] to terminate. If one of
|
||||
the threads fails, then [join l] will fails with the same
|
||||
exception as the first one to terminate.
|
||||
|
||||
Note: {!join} leaves the local values of the current thread
|
||||
unchanged. *)
|
||||
|
||||
val ( <?> ) : 'a t -> 'a t -> 'a t
|
||||
(** [t <?> t'] is the same as [choose [t; t']] *)
|
||||
|
||||
val ( <&> ) : unit t -> unit t -> unit t
|
||||
(** [t <&> t'] is the same as [join [t; t']] *)
|
||||
|
||||
val ignore_result : 'a t -> unit
|
||||
(** [ignore_result t] start the thread [t] and ignores its result
|
||||
value if the thread terminates sucessfully. However, if the
|
||||
thread [t] fails, the exception is raised instead of being
|
||||
ignored.
|
||||
|
||||
You should use this function if you want to start a thread and
|
||||
don't care what its return value is, nor when it terminates (for
|
||||
instance, because it is looping). Note that if the thread [t]
|
||||
yields and later fails, the exception will not be raised at this
|
||||
point in the program. *)
|
||||
|
||||
(** {6 Sleeping and resuming} *)
|
||||
|
||||
type 'a u
|
||||
(** The type of thread wakeners. *)
|
||||
|
||||
val wait : unit -> 'a t * 'a u
|
||||
(** [wait ()] is a pair of a thread which sleeps forever (unless it
|
||||
is resumed by one of the functions [wakeup], [wakeup_exn] below)
|
||||
and the corresponding wakener. This thread does not block the
|
||||
execution of the remainder of the program (except of course, if
|
||||
another thread tries to wait for its termination). *)
|
||||
|
||||
val wakeup : 'a u -> 'a -> unit
|
||||
(** [wakeup t e] makes the sleeping thread [t] terminate and return
|
||||
the value of the expression [e]. *)
|
||||
|
||||
val wakeup_exn : 'a u -> exn -> unit
|
||||
(** [wakeup_exn t e] makes the sleeping thread [t] fail with the
|
||||
exception [e]. *)
|
||||
|
||||
val wakeup_later : 'a u -> 'a -> unit
|
||||
(** Same as {!wakeup} but it is not guaranteed that the thread will
|
||||
be wakeup immediately. *)
|
||||
|
||||
val wakeup_later_exn : 'a u -> exn -> unit
|
||||
(** Same as {!wakeup_exn} but it is not guaranteed that the thread
|
||||
will be wakeup immediately. *)
|
||||
|
||||
val waiter_of_wakener : 'a u -> 'a t
|
||||
(** Returns the thread associated to a wakener. *)
|
||||
|
||||
(** {6 Threads state} *)
|
||||
|
||||
(** State of a thread *)
|
||||
type 'a state =
|
||||
| Return of 'a
|
||||
(** The thread which has successfully terminated *)
|
||||
| Fail of exn
|
||||
(** The thread raised an exception *)
|
||||
| Sleep
|
||||
(** The thread is sleeping *)
|
||||
|
||||
val state : 'a t -> 'a state
|
||||
(** [state t] returns the state of a thread *)
|
||||
|
||||
(** {6 Cancelable threads} *)
|
||||
|
||||
(** Cancelable threads are the same as regular threads except that
|
||||
they can be canceled. *)
|
||||
|
||||
exception Canceled
|
||||
(** Canceled threads fails with this exception *)
|
||||
|
||||
val task : unit -> 'a t * 'a u
|
||||
(** [task ()] is the same as [wait ()] except that threads created
|
||||
with [task] can be canceled. *)
|
||||
|
||||
val on_cancel : 'a t -> (unit -> unit) -> unit
|
||||
(** [on_cancel t f] executes [f] when [t] is canceled. This is the
|
||||
same as catching [Canceled]. *)
|
||||
|
||||
val cancel : 'a t -> unit
|
||||
(** [cancel t] cancels the threads [t]. This means that the deepest
|
||||
sleeping thread created with [task] and connected to [t] is
|
||||
woken up with the exception {!Canceled}.
|
||||
|
||||
For example, in the following code:
|
||||
|
||||
{[
|
||||
let waiter, wakener = task () in
|
||||
cancel (waiter >> printl "plop")
|
||||
]}
|
||||
|
||||
[waiter] will be woken up with {!Canceled}.
|
||||
*)
|
||||
|
||||
val pick : 'a t list -> 'a t
|
||||
(** [pick l] is the same as {!choose}, except that it cancels all
|
||||
sleeping threads when one terminates.
|
||||
|
||||
Note: {!pick} leaves the local values of the current thread
|
||||
unchanged. *)
|
||||
|
||||
val npick : 'a t list -> 'a list t
|
||||
(** [npick l] is the same as {!nchoose}, except that it cancels all
|
||||
sleeping threads when one terminates.
|
||||
|
||||
Note: {!npick} leaves the local values of the current thread
|
||||
unchanged. *)
|
||||
|
||||
val protected : 'a t -> 'a t
|
||||
(** [protected thread] creates a new cancelable thread which behave
|
||||
as [thread] except that cancelling it does not cancel
|
||||
[thread]. *)
|
||||
|
||||
(** {6 Pause} *)
|
||||
|
||||
val pause : unit -> unit t
|
||||
(** [pause ()] is a sleeping thread which is wake up on the next
|
||||
call to {!wakeup_paused}. A thread created with [pause] can be
|
||||
canceled. *)
|
||||
|
||||
val wakeup_paused : unit -> unit
|
||||
(** [wakeup_paused ()] wakes up all threads which suspended
|
||||
themselves with {!pause}.
|
||||
|
||||
This function is called by the scheduler, before entering the
|
||||
main loop. You usually do not have to call it directly, except
|
||||
if you are writing a custom scheduler.
|
||||
|
||||
Note that if a paused thread resume and pause again, it will not
|
||||
be wakeup at this point. *)
|
||||
|
||||
val paused_count : unit -> int
|
||||
(** [paused_count ()] returns the number of thread currently
|
||||
paused. *)
|
||||
|
||||
val register_pause_notifier : (int -> unit) -> unit
|
||||
(** [register_pause_notifier f] register a function [f] that will be
|
||||
called each time pause is called. The parameter passed to [f] is
|
||||
the new number of threads paused. It is usefull to be able to
|
||||
call {!wakeup_paused} when there is no scheduler *)
|
||||
|
||||
(** {6 Misc} *)
|
||||
|
||||
val on_success : 'a t -> ('a -> unit) -> unit
|
||||
(** [on_success t f] executes [f] when [t] terminates without
|
||||
failing. This is the same as:
|
||||
|
||||
{[
|
||||
ignore_result (bind t (fun x -> f x; return ()))
|
||||
]}
|
||||
|
||||
but a bit more efficient.
|
||||
*)
|
||||
|
||||
val on_failure : 'a t -> (exn -> unit) -> unit
|
||||
(** [on_failure t f] executes [f] when [t] terminates and
|
||||
fails. This is the same as:
|
||||
|
||||
{[
|
||||
ignore_result (catch t (fun e -> f e; return ()))
|
||||
]}
|
||||
|
||||
but a bit more efficient.
|
||||
*)
|
||||
|
||||
val on_termination : 'a t -> (unit -> unit) -> unit
|
||||
(** [on_termination t f] executes [f] when [t] terminates. This is
|
||||
the same as:
|
||||
|
||||
{[
|
||||
ignore_result (finalize (fun () -> t) (fun () -> f (); return ()))
|
||||
]}
|
||||
|
||||
but a bit more efficient.
|
||||
*)
|
||||
|
||||
(**/**)
|
||||
|
||||
(* The functions below are probably not useful for the casual user.
|
||||
They provide the basic primitives on which can be built multi-
|
||||
threaded libraries such as Lwt_unix. *)
|
||||
|
||||
val poll : 'a t -> 'a option
|
||||
(* [poll e] returns [Some v] if the thread [e] is terminated and
|
||||
returned the value [v]. If the thread failed with some
|
||||
exception, this exception is raised. If the thread is still
|
||||
running, [poll e] returns [None] without blocking. *)
|
||||
|
||||
val apply : ('a -> 'b t) -> 'a -> 'b t
|
||||
(* [apply f e] apply the function [f] to the expression [e]. If
|
||||
an exception is raised during this application, it is caught
|
||||
and the resulting thread fails with this exception. *)
|
||||
(* Q: Could be called 'glue' or 'trap' or something? *)
|
||||
|
||||
val backtrace_bind : (exn -> exn) -> 'a t -> ('a -> 'b t) -> 'b t
|
||||
val backtrace_catch : (exn -> exn) -> (unit -> 'a t) -> (exn -> 'a t) -> 'a t
|
||||
val backtrace_try_bind : (exn -> exn) -> (unit -> 'a t) -> ('a -> 'b t) -> (exn -> 'b t) -> 'b t
|
||||
val backtrace_finalize : (exn -> exn) -> (unit -> 'a t) -> (unit -> unit t) -> 'a t
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
# OASIS_START
|
||||
# DO NOT EDIT (digest: ecdfab02163af2abad730a4cf20c2630)
|
||||
Lwt_condition
|
||||
Lwt_list
|
||||
Lwt
|
||||
Lwt_mutex
|
||||
Lwt_mvar
|
||||
Lwt_pool
|
||||
Lwt_sequence
|
||||
Lwt_stream
|
||||
Lwt_switch
|
||||
Lwt_util
|
||||
Lwt_pqueue
|
||||
# OASIS_STOP
|
|
@ -0,0 +1,63 @@
|
|||
(******************************************************************************)
|
||||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Module Lwt_condition
|
||||
******************************************************************************
|
||||
* Copyright (c) 2009, Metaweb Technologies, Inc.
|
||||
* All rights reserved.
|
||||
*
|
||||
* Redistribution and use in source and binary forms, with or without
|
||||
* modification, are permitted provided that the following conditions
|
||||
* are met:
|
||||
* * Redistributions of source code must retain the above copyright
|
||||
* notice, this list of conditions and the following disclaimer.
|
||||
* * Redistributions in binary form must reproduce the above
|
||||
* copyright notice, this list of conditions and the following
|
||||
* disclaimer in the documentation and/or other materials provided
|
||||
* with the distribution.
|
||||
*
|
||||
* THIS SOFTWARE IS PROVIDED BY METAWEB TECHNOLOGIES ``AS IS'' AND ANY
|
||||
* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
||||
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL METAWEB TECHNOLOGIES BE
|
||||
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
|
||||
* BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
||||
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
|
||||
* OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
|
||||
* IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
******************************************************************************)
|
||||
|
||||
open Lwt
|
||||
|
||||
type 'a t = 'a Lwt.u Lwt_sequence.t
|
||||
|
||||
let create = Lwt_sequence.create
|
||||
|
||||
let wait ?mutex cvar =
|
||||
let waiter, wakener = Lwt.task () in
|
||||
let node = Lwt_sequence.add_r wakener cvar in
|
||||
on_cancel waiter (fun () -> Lwt_sequence.remove node);
|
||||
let () =
|
||||
match mutex with
|
||||
| Some m -> Lwt_mutex.unlock m
|
||||
| None -> ()
|
||||
in
|
||||
try_lwt
|
||||
waiter
|
||||
finally
|
||||
match mutex with
|
||||
| Some m -> Lwt_mutex.lock m
|
||||
| None -> return ()
|
||||
|
||||
let signal cvar arg =
|
||||
try
|
||||
wakeup_later (Lwt_sequence.take_l cvar) arg
|
||||
with Lwt_sequence.Empty ->
|
||||
()
|
||||
|
||||
let broadcast cvar arg =
|
||||
let wakeners = Lwt_sequence.fold_r (fun x l -> x :: l) cvar [] in
|
||||
Lwt_sequence.iter_node_l Lwt_sequence.remove cvar;
|
||||
List.iter (fun wakener -> wakeup_later wakener arg) wakeners
|
|
@ -0,0 +1,65 @@
|
|||
(******************************************************************************)
|
||||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Interface Lwt_condition
|
||||
******************************************************************************
|
||||
* Copyright (c) 2009, Metaweb Technologies, Inc.
|
||||
* All rights reserved.
|
||||
*
|
||||
* Redistribution and use in source and binary forms, with or without
|
||||
* modification, are permitted provided that the following conditions
|
||||
* are met:
|
||||
* * Redistributions of source code must retain the above copyright
|
||||
* notice, this list of conditions and the following disclaimer.
|
||||
* * Redistributions in binary form must reproduce the above
|
||||
* copyright notice, this list of conditions and the following
|
||||
* disclaimer in the documentation and/or other materials provided
|
||||
* with the distribution.
|
||||
*
|
||||
* THIS SOFTWARE IS PROVIDED BY METAWEB TECHNOLOGIES ``AS IS'' AND ANY
|
||||
* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
||||
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL METAWEB TECHNOLOGIES BE
|
||||
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
|
||||
* BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
||||
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
|
||||
* OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
|
||||
* IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
******************************************************************************)
|
||||
|
||||
(** Conditions *)
|
||||
|
||||
(** Condition variables to synchronize between threads. *)
|
||||
|
||||
type 'a t
|
||||
(** Condition variable type. The type parameter denotes the type of
|
||||
value propagated from notifier to waiter. *)
|
||||
|
||||
val create : unit -> 'a t
|
||||
(** [create ()] creates a new condition variable. *)
|
||||
|
||||
val wait : ?mutex:Lwt_mutex.t -> 'a t -> 'a Lwt.t
|
||||
(** [wait mutex condvar] will cause the current thread to block,
|
||||
awaiting notification for a condition variable, [condvar]. If
|
||||
provided, the [mutex] must have been previously locked (within
|
||||
the scope of [Lwt_mutex.with_lock], for example) and is
|
||||
temporarily unlocked until the condition is notified. Upon
|
||||
notification, [mutex] is re-locked before [wait] returns and
|
||||
the thread's activity is resumed. When the awaited condition
|
||||
is notified, the value parameter passed to [notify] is
|
||||
returned. *)
|
||||
|
||||
val signal : 'a t -> 'a -> unit
|
||||
(** [signal condvar value] notifies that a condition is ready. A
|
||||
single waiting thread will be awoken and will receive the
|
||||
notification value which will be returned from [wait]. Note
|
||||
that condition notification is not "sticky", i.e. if there is
|
||||
no waiter when [notify] is called, the notification will be
|
||||
missed and the value discarded. *)
|
||||
|
||||
val broadcast : 'a t -> 'a -> unit
|
||||
(** [broadcast condvar value] notifies all waiting threads. Each
|
||||
will be awoken in turn and will receive the same notification
|
||||
value. *)
|
|
@ -0,0 +1,189 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Module Lwt_list
|
||||
* Copyright (C) 2010 Jérémie Dimino
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
open Lwt
|
||||
|
||||
let rec iter_s f l =
|
||||
match l with
|
||||
| [] ->
|
||||
return ()
|
||||
| x :: l ->
|
||||
lwt () = f x in
|
||||
iter_s f l
|
||||
|
||||
let rec iter_p f l =
|
||||
match l with
|
||||
| [] ->
|
||||
return ()
|
||||
| x :: l ->
|
||||
let t = f x and lt = iter_p f l in
|
||||
lwt () = t in
|
||||
lt
|
||||
|
||||
let rec map_s f l =
|
||||
match l with
|
||||
| [] ->
|
||||
return []
|
||||
| x :: l ->
|
||||
lwt x = f x in
|
||||
lwt l = map_s f l in
|
||||
return (x :: l)
|
||||
|
||||
let rec map_p f l =
|
||||
match l with
|
||||
| [] ->
|
||||
return []
|
||||
| x :: l ->
|
||||
lwt x = f x and l = map_p f l in
|
||||
return (x :: l)
|
||||
|
||||
let rec rev_map_append_s acc f l =
|
||||
match l with
|
||||
| [] ->
|
||||
return acc
|
||||
| x :: l ->
|
||||
lwt x = f x in
|
||||
rev_map_append_s (x :: acc) f l
|
||||
|
||||
let rev_map_s f l =
|
||||
rev_map_append_s [] f l
|
||||
|
||||
let rec rev_map_append_p acc f l =
|
||||
match l with
|
||||
| [] ->
|
||||
acc
|
||||
| x :: l ->
|
||||
rev_map_append_p (lwt x = f x and l = acc in return (x :: l)) f l
|
||||
|
||||
let rev_map_p f l =
|
||||
rev_map_append_p (return []) f l
|
||||
|
||||
let rec fold_left_s f acc l =
|
||||
match l with
|
||||
| [] ->
|
||||
return acc
|
||||
| x :: l ->
|
||||
lwt acc = f acc x in
|
||||
fold_left_s f acc l
|
||||
|
||||
let rec fold_right_s f l acc =
|
||||
match l with
|
||||
| [] ->
|
||||
return acc
|
||||
| x :: l ->
|
||||
lwt acc = fold_right_s f l acc in
|
||||
f x acc
|
||||
|
||||
let rec for_all_s f l =
|
||||
match l with
|
||||
| [] ->
|
||||
return true
|
||||
| x :: l ->
|
||||
f x >>= function
|
||||
| true ->
|
||||
for_all_s f l
|
||||
| false ->
|
||||
return false
|
||||
|
||||
let rec for_all_p f l =
|
||||
match l with
|
||||
| [] ->
|
||||
return true
|
||||
| x :: l ->
|
||||
lwt bx = f x and bl = for_all_p f l in
|
||||
return (bx && bl)
|
||||
|
||||
let rec exists_s f l =
|
||||
match l with
|
||||
| [] ->
|
||||
return false
|
||||
| x :: l ->
|
||||
f x >>= function
|
||||
| true ->
|
||||
return true
|
||||
| false ->
|
||||
exists_s f l
|
||||
|
||||
let rec exists_p f l =
|
||||
match l with
|
||||
| [] ->
|
||||
return false
|
||||
| x :: l ->
|
||||
lwt bx = f x and bl = exists_p f l in
|
||||
return (bx || bl)
|
||||
|
||||
let rec find_s f l =
|
||||
match l with
|
||||
| [] ->
|
||||
raise_lwt Not_found
|
||||
| x :: l ->
|
||||
f x >>= function
|
||||
| true ->
|
||||
return x
|
||||
| false ->
|
||||
find_s f l
|
||||
|
||||
let rec filter_s f l =
|
||||
match l with
|
||||
| [] ->
|
||||
return []
|
||||
| x :: l ->
|
||||
f x >>= function
|
||||
| true ->
|
||||
lwt l = filter_s f l in
|
||||
return (x :: l)
|
||||
| false ->
|
||||
filter_s f l
|
||||
|
||||
let rec filter_p f l =
|
||||
match l with
|
||||
| [] ->
|
||||
return []
|
||||
| x :: l ->
|
||||
lwt bx = f x and l = filter_p f l in
|
||||
if bx then
|
||||
return (x :: l)
|
||||
else
|
||||
return l
|
||||
|
||||
let rec partition_s f l =
|
||||
match l with
|
||||
| [] ->
|
||||
return ([], [])
|
||||
| x :: l ->
|
||||
lwt bx = f x in
|
||||
lwt l_l, l_r = partition_s f l in
|
||||
if bx then
|
||||
return (x :: l_l, l_r)
|
||||
else
|
||||
return (l_l, x :: l_r)
|
||||
|
||||
let rec partition_p f l =
|
||||
match l with
|
||||
| [] ->
|
||||
return ([], [])
|
||||
| x :: l ->
|
||||
lwt bx = f x and l_l, l_r = partition_p f l in
|
||||
if bx then
|
||||
return (x :: l_l, l_r)
|
||||
else
|
||||
return (l_l, x :: l_r)
|
|
@ -0,0 +1,59 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Interface Lwt_list
|
||||
* Copyright (C) 2010 Jérémie Dimino
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
(** List helpers *)
|
||||
|
||||
(** Note: this module use the same naming convention as
|
||||
{!Lwt_stream}. *)
|
||||
|
||||
(** {6 List iterators} *)
|
||||
|
||||
val iter_s : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t
|
||||
val iter_p : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t
|
||||
|
||||
val map_s : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t
|
||||
val map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t
|
||||
|
||||
val rev_map_s : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t
|
||||
val rev_map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t
|
||||
|
||||
val fold_left_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b list -> 'a Lwt.t
|
||||
|
||||
val fold_right_s : ('a -> 'b -> 'b Lwt.t) -> 'a list -> 'b -> 'b Lwt.t
|
||||
|
||||
(** {6 List scanning} *)
|
||||
|
||||
val for_all_s : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t
|
||||
val for_all_p : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t
|
||||
|
||||
val exists_s : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t
|
||||
val exists_p : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t
|
||||
|
||||
(** {6 List searching} *)
|
||||
|
||||
val find_s : ('a -> bool Lwt.t) -> 'a list -> 'a Lwt.t
|
||||
|
||||
val filter_s : ('a -> bool Lwt.t) -> 'a list -> 'a list Lwt.t
|
||||
val filter_p : ('a -> bool Lwt.t) -> 'a list -> 'a list Lwt.t
|
||||
|
||||
val partition_s : ('a -> bool Lwt.t) -> 'a list -> ('a list * 'a list) Lwt.t
|
||||
val partition_p : ('a -> bool Lwt.t) -> 'a list -> ('a list * 'a list) Lwt.t
|
|
@ -0,0 +1,60 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Module Lwt_mutex
|
||||
* Copyright (C) 2005-2008 Jérôme Vouillon
|
||||
* Laboratoire PPS - CNRS Université Paris Diderot
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
open Lwt
|
||||
|
||||
type t = { mutable locked : bool; mutable waiters : unit Lwt.u Lwt_sequence.t }
|
||||
|
||||
let create () = { locked = false; waiters = Lwt_sequence.create () }
|
||||
|
||||
let rec lock m =
|
||||
if m.locked then begin
|
||||
let (res, w) = Lwt.task () in
|
||||
let node = Lwt_sequence.add_r w m.waiters in
|
||||
Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node);
|
||||
res
|
||||
end else begin
|
||||
m.locked <- true;
|
||||
Lwt.return ()
|
||||
end
|
||||
|
||||
let unlock m =
|
||||
if m.locked then begin
|
||||
if Lwt_sequence.is_empty m.waiters then
|
||||
m.locked <- false
|
||||
else
|
||||
(* We do not use [Lwt.wakeup] here to avoid a stack overflow
|
||||
when unlocking a lot of threads. *)
|
||||
Lwt.wakeup_later (Lwt_sequence.take_l m.waiters) ()
|
||||
end
|
||||
|
||||
let with_lock m f =
|
||||
lwt () = lock m in
|
||||
try_lwt
|
||||
f ()
|
||||
finally
|
||||
unlock m;
|
||||
return ()
|
||||
|
||||
let is_locked m = m.locked
|
||||
let is_empty m = Lwt_sequence.is_empty m.waiters
|
|
@ -0,0 +1,62 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Interface Lwt_mutex
|
||||
* Copyright (C) 2005-2008 Jérôme Vouillon
|
||||
* Laboratoire PPS - CNRS Université Paris Diderot
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
(** Cooperative locks for mutual exclusion *)
|
||||
|
||||
type t
|
||||
(** Type of Lwt mutexes *)
|
||||
|
||||
val create : unit -> t
|
||||
(** [create ()] creates a new mutex, which is initially unlocked *)
|
||||
|
||||
val lock : t -> unit Lwt.t
|
||||
(** [lock mutex] lockcs the mutex, that is:
|
||||
|
||||
- if the mutex is unlocked, then it is marked as locked and
|
||||
{!lock} returns immediatly
|
||||
|
||||
- if it is locked, then {!lock} waits for all threads waiting on
|
||||
the mutex to terminate, then it resumes when the last one
|
||||
unlocks the mutex
|
||||
|
||||
Note: threads are wake up is the same order they try to lock the
|
||||
mutex *)
|
||||
|
||||
val unlock : t -> unit
|
||||
(** [unlock mutex] unlock the mutex if no threads is waiting on
|
||||
it. Otherwise it will eventually removes the first one and
|
||||
resumes it. *)
|
||||
|
||||
val is_locked : t -> bool
|
||||
(** [locked mutex] returns whether [mutex] is currently locked *)
|
||||
|
||||
val is_empty : t -> bool
|
||||
(** [is_empty mutex] returns [true] if they are no thread waiting on
|
||||
the mutex, and [false] otherwise *)
|
||||
|
||||
val with_lock : t -> (unit -> 'a Lwt.t) -> 'a Lwt.t
|
||||
(** [with_lock lock f] is used to lock a mutex within a block scope.
|
||||
The function [f ()] is called with the mutex locked, and its
|
||||
result is returned from the call to {with_lock}. If an exception
|
||||
is raised from f, the mutex is also unlocked before the scope of
|
||||
{with_lock} is exited. *)
|
|
@ -0,0 +1,87 @@
|
|||
(* -*- Mode: Caml; indent-tabs-mode: nil -*- *)
|
||||
(******************************************************************************)
|
||||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Interface Lwt_mon
|
||||
******************************************************************************
|
||||
* Copyright (c) 2009, Metaweb Technologies, Inc.
|
||||
* All rights reserved.
|
||||
*
|
||||
* Redistribution and use in source and binary forms, with or without
|
||||
* modification, are permitted provided that the following conditions
|
||||
* are met:
|
||||
* * Redistributions of source code must retain the above copyright
|
||||
* notice, this list of conditions and the following disclaimer.
|
||||
* * Redistributions in binary form must reproduce the above
|
||||
* copyright notice, this list of conditions and the following
|
||||
* disclaimer in the documentation and/or other materials provided
|
||||
* with the distribution.
|
||||
*
|
||||
* THIS SOFTWARE IS PROVIDED BY METAWEB TECHNOLOGIES ``AS IS'' AND ANY
|
||||
* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
||||
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL METAWEB TECHNOLOGIES BE
|
||||
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
|
||||
* BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
||||
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
|
||||
* OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
|
||||
* IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
******************************************************************************)
|
||||
|
||||
let return_unit = Lwt.return ()
|
||||
|
||||
type 'a t = {
|
||||
mutable contents : 'a option;
|
||||
(* Current contents *)
|
||||
|
||||
mutable writers : ('a * unit Lwt.u) Lwt_sequence.t;
|
||||
(* Threads waiting to put a value *)
|
||||
|
||||
mutable readers : 'a Lwt.u Lwt_sequence.t;
|
||||
(* Threads waiting for a value *)
|
||||
}
|
||||
|
||||
let create_empty () =
|
||||
{ contents = None;
|
||||
writers = Lwt_sequence.create ();
|
||||
readers = Lwt_sequence.create () }
|
||||
|
||||
let create v =
|
||||
{ contents = Some v;
|
||||
writers = Lwt_sequence.create ();
|
||||
readers = Lwt_sequence.create () }
|
||||
|
||||
let put mvar v =
|
||||
match mvar.contents with
|
||||
| None ->
|
||||
begin match Lwt_sequence.take_opt_l mvar.readers with
|
||||
| None ->
|
||||
mvar.contents <- Some v
|
||||
| Some w ->
|
||||
Lwt.wakeup_later w v
|
||||
end;
|
||||
return_unit
|
||||
| Some _ ->
|
||||
let (res, w) = Lwt.task () in
|
||||
let node = Lwt_sequence.add_r (v, w) mvar.writers in
|
||||
Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node);
|
||||
res
|
||||
|
||||
let take mvar =
|
||||
match mvar.contents with
|
||||
| Some v ->
|
||||
begin match Lwt_sequence.take_opt_l mvar.writers with
|
||||
| Some(v', w) ->
|
||||
mvar.contents <- Some v';
|
||||
Lwt.wakeup_later w ()
|
||||
| None ->
|
||||
mvar.contents <- None
|
||||
end;
|
||||
Lwt.return v
|
||||
| None ->
|
||||
let (res, w) = Lwt.task () in
|
||||
let node = Lwt_sequence.add_r w mvar.readers in
|
||||
Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node);
|
||||
res
|
|
@ -0,0 +1,63 @@
|
|||
(* -*- Mode: Caml; indent-tabs-mode: nil -*- *)
|
||||
(******************************************************************************)
|
||||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Interface Lwt_mon
|
||||
******************************************************************************
|
||||
* Copyright (c) 2009, Metaweb Technologies, Inc.
|
||||
* All rights reserved.
|
||||
*
|
||||
* Redistribution and use in source and binary forms, with or without
|
||||
* modification, are permitted provided that the following conditions
|
||||
* are met:
|
||||
* * Redistributions of source code must retain the above copyright
|
||||
* notice, this list of conditions and the following disclaimer.
|
||||
* * Redistributions in binary form must reproduce the above
|
||||
* copyright notice, this list of conditions and the following
|
||||
* disclaimer in the documentation and/or other materials provided
|
||||
* with the distribution.
|
||||
*
|
||||
* THIS SOFTWARE IS PROVIDED BY METAWEB TECHNOLOGIES ``AS IS'' AND ANY
|
||||
* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
||||
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL METAWEB TECHNOLOGIES BE
|
||||
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
|
||||
* BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
||||
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
|
||||
* OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
|
||||
* IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
******************************************************************************)
|
||||
|
||||
(** Mailbox variables *)
|
||||
|
||||
(** "Mailbox" variables implement a synchronising variable, used for
|
||||
communication between concurrent threads.
|
||||
|
||||
This code adapted from
|
||||
{{:http://eigenclass.org/hiki.rb?cmd=view&p=lightweight-threads-with-lwt}Comparing lightweight threads (eigenclass.org)} *)
|
||||
|
||||
type 'a t
|
||||
(** The type of a mailbox variable. Mailbox variables are used to
|
||||
communicate values between threads in a synchronous way. The
|
||||
type parameter specifies the type of the value propagated from
|
||||
[put] to [take]. *)
|
||||
|
||||
val create : 'a -> 'a t
|
||||
(** [create v] creates a new mailbox variable containing value [v]. *)
|
||||
|
||||
val create_empty : unit -> 'a t
|
||||
(** [create ()] creates a new empty mailbox variable. *)
|
||||
|
||||
val put : 'a t -> 'a -> unit Lwt.t
|
||||
(** [put mvar value] puts a value into a mailbox variable. This
|
||||
value will remain in the mailbox until [take] is called to
|
||||
remove it. If the mailbox is not empty, the current thread will
|
||||
block until it is emptied. *)
|
||||
|
||||
val take : 'a t -> 'a Lwt.t
|
||||
(** [take mvar] will take any currently available value from the
|
||||
mailbox variable. If no value is currently available, the
|
||||
current thread will block, awaiting a value to be [put] by
|
||||
another thread. *)
|
|
@ -0,0 +1,93 @@
|
|||
(* Lwt
|
||||
* http://www.ocsigen.org
|
||||
* Copyright (C) 2008 Jérôme Vouillon
|
||||
* Laboratoire PPS - CNRS Université Paris Diderot
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later version.
|
||||
* See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful,
|
||||
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
* GNU Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
*)
|
||||
|
||||
open Lwt
|
||||
|
||||
(*
|
||||
XXX Close after some timeout
|
||||
...
|
||||
*)
|
||||
|
||||
type 'a t =
|
||||
{ create : unit -> 'a Lwt.t;
|
||||
check : 'a -> (bool -> unit) -> unit;
|
||||
max : int;
|
||||
mutable count : int;
|
||||
list : 'a Queue.t;
|
||||
waiters : 'a Lwt.u Lwt_sequence.t }
|
||||
|
||||
let create m ?(check = fun _ f -> f true) create =
|
||||
{ max = m;
|
||||
create = create;
|
||||
check = check;
|
||||
count = 0;
|
||||
list = Queue.create ();
|
||||
waiters = Lwt_sequence.create () }
|
||||
|
||||
let create_member p =
|
||||
try_lwt
|
||||
p.count <- p.count + 1; (* must be done before p.create *)
|
||||
lwt mem = p.create () in
|
||||
return mem
|
||||
with exn ->
|
||||
(* create failed, so don't increment count *)
|
||||
p.count <- p.count - 1;
|
||||
raise_lwt exn
|
||||
|
||||
let acquire p =
|
||||
try
|
||||
return (Queue.take p.list)
|
||||
with Queue.Empty ->
|
||||
if p.count < p.max then
|
||||
create_member p
|
||||
else begin
|
||||
let waiter, wakener = task () in
|
||||
let node = Lwt_sequence.add_r wakener p.waiters in
|
||||
on_cancel waiter (fun () -> Lwt_sequence.remove node);
|
||||
waiter
|
||||
end
|
||||
|
||||
let release p c =
|
||||
try
|
||||
wakeup_later (Lwt_sequence.take_l p.waiters) c
|
||||
with Lwt_sequence.Empty ->
|
||||
Queue.push c p.list
|
||||
|
||||
let checked_release p c =
|
||||
p.check c begin fun ok ->
|
||||
if ok then
|
||||
release p c
|
||||
else
|
||||
ignore (p.count <- p.count - 1;
|
||||
lwt c = create_member p in
|
||||
release p c;
|
||||
return ())
|
||||
end
|
||||
|
||||
let use p f =
|
||||
lwt c = acquire p in
|
||||
try_lwt
|
||||
lwt r = f c in
|
||||
release p c;
|
||||
return r
|
||||
with e ->
|
||||
checked_release p c;
|
||||
raise_lwt e
|
|
@ -0,0 +1,40 @@
|
|||
(* Lwt
|
||||
* http://www.ocsigen.org
|
||||
* Copyright (C) 2008 Jérôme Vouillon
|
||||
* Laboratoire PPS - CNRS Université Paris Diderot
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later version.
|
||||
* See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful,
|
||||
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
* GNU Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
*)
|
||||
|
||||
(** Creating pools (for example pools of connections to a database). *)
|
||||
|
||||
(** Instead of creating a new connection each time you need one,
|
||||
keep a pool of opened connections and reuse opened connections
|
||||
that are free.
|
||||
*)
|
||||
|
||||
(** Type of pools *)
|
||||
type 'a t
|
||||
|
||||
(** [create n f] creates a new pool with at most [n] members.
|
||||
[f] is the function to use to create a new pool member. *)
|
||||
val create :
|
||||
int -> ?check:('a -> (bool -> unit) -> unit) -> (unit -> 'a Lwt.t) -> 'a t
|
||||
|
||||
(** [use p f] takes one free member of the pool [p] and gives it to the function
|
||||
[f].
|
||||
*)
|
||||
val use : 'a t -> ('a -> 'b Lwt.t) -> 'b Lwt.t
|
|
@ -0,0 +1,108 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Module Lwt_pqueue
|
||||
* Copyright (C) 1999-2004 Jérôme Vouillon
|
||||
* Laboratoire PPS - CNRS Université Paris Diderot
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
module type OrderedType =
|
||||
sig
|
||||
type t
|
||||
val compare: t -> t -> int
|
||||
end
|
||||
|
||||
module type S =
|
||||
sig
|
||||
type elt
|
||||
type t
|
||||
val empty: t
|
||||
val is_empty: t -> bool
|
||||
val add: elt -> t -> t
|
||||
val union: t -> t -> t
|
||||
val find_min: t -> elt
|
||||
val lookup_min: t -> elt option
|
||||
val remove_min: t -> t
|
||||
val size: t -> int
|
||||
end
|
||||
|
||||
module Make(Ord: OrderedType) : (S with type elt = Ord.t) =
|
||||
struct
|
||||
type elt = Ord.t
|
||||
|
||||
type t = tree list
|
||||
and tree = Node of elt * int * tree list
|
||||
|
||||
let root (Node (x, _, _)) = x
|
||||
let rank (Node (_, r, _)) = r
|
||||
let link (Node (x1, r1, c1) as t1) (Node (x2, r2, c2) as t2) =
|
||||
let c = Ord.compare x1 x2 in
|
||||
if c <= 0 then Node (x1, r1 + 1, t2::c1) else Node(x2, r2 + 1, t1::c2)
|
||||
let rec ins t =
|
||||
function
|
||||
[] ->
|
||||
[t]
|
||||
| (t'::_) as ts when rank t < rank t' ->
|
||||
t::ts
|
||||
| t'::ts ->
|
||||
ins (link t t') ts
|
||||
|
||||
let empty = []
|
||||
let is_empty ts = ts = []
|
||||
let add x ts = ins (Node (x, 0, [])) ts
|
||||
let rec union ts ts' =
|
||||
match ts, ts' with
|
||||
([], _) -> ts'
|
||||
| (_, []) -> ts
|
||||
| (t1::ts1, t2::ts2) ->
|
||||
if rank t1 < rank t2 then t1 :: union ts1 (t2::ts2)
|
||||
else if rank t2 < rank t1 then t2 :: union (t1::ts1) ts2
|
||||
else ins (link t1 t2) (union ts1 ts2)
|
||||
|
||||
let rec find_min =
|
||||
function
|
||||
[] -> raise Not_found
|
||||
| [t] -> root t
|
||||
| t::ts ->
|
||||
let x = find_min ts in
|
||||
let c = Ord.compare (root t) x in
|
||||
if c < 0 then root t else x
|
||||
|
||||
let lookup_min t =
|
||||
try Some(find_min t) with Not_found -> None
|
||||
|
||||
let rec get_min =
|
||||
function
|
||||
[] -> assert false
|
||||
| [t] -> (t, [])
|
||||
| t::ts ->
|
||||
let (t', ts') = get_min ts in
|
||||
let c = Ord.compare (root t) (root t') in
|
||||
if c < 0 then (t, ts) else (t', t::ts')
|
||||
|
||||
let remove_min =
|
||||
function
|
||||
[] -> raise Not_found
|
||||
| ts ->
|
||||
let (Node (x, r, c), ts) = get_min ts in
|
||||
union (List.rev c) ts
|
||||
|
||||
let rec size l =
|
||||
let rec sizetree (Node (_,_,tl)) = 1 + size tl in
|
||||
List.fold_left (fun s t -> s + sizetree t) 0 l
|
||||
end
|
|
@ -0,0 +1,44 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Interface Lwt_pqueue
|
||||
* Copyright (C) 1999-2004 Jérôme Vouillon
|
||||
* Laboratoire PPS - CNRS Université Paris Diderot
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
module type OrderedType =
|
||||
sig
|
||||
type t
|
||||
val compare: t -> t -> int
|
||||
end
|
||||
|
||||
module type S =
|
||||
sig
|
||||
type elt
|
||||
type t
|
||||
val empty: t
|
||||
val is_empty: t -> bool
|
||||
val add: elt -> t -> t
|
||||
val union: t -> t -> t
|
||||
val find_min: t -> elt
|
||||
val lookup_min: t -> elt option
|
||||
val remove_min: t -> t
|
||||
val size: t -> int
|
||||
end
|
||||
|
||||
module Make(Ord: OrderedType) : S with type elt = Ord.t
|
|
@ -0,0 +1,209 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Module Lwt_sequence
|
||||
* Copyright (C) 2009 Jérémie Dimino
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
exception Empty
|
||||
|
||||
type 'a t = {
|
||||
mutable prev : 'a t;
|
||||
mutable next : 'a t;
|
||||
}
|
||||
|
||||
type 'a node = {
|
||||
mutable node_prev : 'a t;
|
||||
mutable node_next : 'a t;
|
||||
mutable node_data : 'a;
|
||||
mutable node_active : bool;
|
||||
}
|
||||
|
||||
external seq_of_node : 'a node -> 'a t = "%identity"
|
||||
external node_of_seq : 'a t -> 'a node = "%identity"
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Operations on nodes |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let get node =
|
||||
node.node_data
|
||||
|
||||
let set node data =
|
||||
node.node_data <- data
|
||||
|
||||
let remove node =
|
||||
if node.node_active then begin
|
||||
node.node_active <- false;
|
||||
let seq = seq_of_node node in
|
||||
seq.prev.next <- seq.next;
|
||||
seq.next.prev <- seq.prev
|
||||
end
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Operations on sequences |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let create () =
|
||||
let rec seq = { prev = seq; next = seq } in
|
||||
seq
|
||||
|
||||
let is_empty seq = seq.next == seq
|
||||
|
||||
let length seq =
|
||||
let rec loop curr len =
|
||||
if curr == seq then
|
||||
len
|
||||
else
|
||||
let node = node_of_seq curr in
|
||||
if node.node_active then
|
||||
loop node.node_next (len + 1)
|
||||
else
|
||||
loop node.node_next len
|
||||
in
|
||||
loop seq.next 0
|
||||
|
||||
let add_l data seq =
|
||||
let node = { node_prev = seq; node_next = seq.next; node_data = data; node_active = true } in
|
||||
seq.next.prev <- seq_of_node node;
|
||||
seq.next <- seq_of_node node;
|
||||
node
|
||||
|
||||
let add_r data seq =
|
||||
let node = { node_prev = seq.prev; node_next = seq; node_data = data; node_active = true } in
|
||||
seq.prev.next <- seq_of_node node;
|
||||
seq.prev <- seq_of_node node;
|
||||
node
|
||||
|
||||
let take_l seq =
|
||||
if is_empty seq then
|
||||
raise Empty
|
||||
else begin
|
||||
let node = node_of_seq seq.next in
|
||||
remove node;
|
||||
node.node_data
|
||||
end
|
||||
|
||||
let take_r seq =
|
||||
if is_empty seq then
|
||||
raise Empty
|
||||
else begin
|
||||
let node = node_of_seq seq.prev in
|
||||
remove node;
|
||||
node.node_data
|
||||
end
|
||||
|
||||
let take_opt_l seq =
|
||||
if is_empty seq then
|
||||
None
|
||||
else begin
|
||||
let node = node_of_seq seq.next in
|
||||
remove node;
|
||||
Some node.node_data
|
||||
end
|
||||
|
||||
let take_opt_r seq =
|
||||
if is_empty seq then
|
||||
None
|
||||
else begin
|
||||
let node = node_of_seq seq.prev in
|
||||
remove node;
|
||||
Some node.node_data
|
||||
end
|
||||
|
||||
let transfer_l s1 s2 =
|
||||
s2.next.prev <- s1.prev;
|
||||
s1.prev.next <- s2.next;
|
||||
s2.next <- s1.next;
|
||||
s1.next.prev <- s2;
|
||||
s1.prev <- s1;
|
||||
s1.next <- s1
|
||||
|
||||
let transfer_r s1 s2 =
|
||||
s2.prev.next <- s1.next;
|
||||
s1.next.prev <- s2.prev;
|
||||
s2.prev <- s1.prev;
|
||||
s1.prev.next <- s2;
|
||||
s1.prev <- s1;
|
||||
s1.next <- s1
|
||||
|
||||
let iter_l f seq =
|
||||
let rec loop curr =
|
||||
if curr != seq then begin
|
||||
let node = node_of_seq curr in
|
||||
if node.node_active then f node.node_data;
|
||||
loop node.node_next
|
||||
end
|
||||
in
|
||||
loop seq.next
|
||||
|
||||
let iter_r f seq =
|
||||
let rec loop curr =
|
||||
if curr != seq then begin
|
||||
let node = node_of_seq curr in
|
||||
if node.node_active then f node.node_data;
|
||||
loop node.node_prev
|
||||
end
|
||||
in
|
||||
loop seq.prev
|
||||
|
||||
let iter_node_l f seq =
|
||||
let rec loop curr =
|
||||
if curr != seq then begin
|
||||
let node = node_of_seq curr in
|
||||
if node.node_active then f node;
|
||||
loop node.node_next
|
||||
end
|
||||
in
|
||||
loop seq.next
|
||||
|
||||
let iter_node_r f seq =
|
||||
let rec loop curr =
|
||||
if curr != seq then begin
|
||||
let node = node_of_seq curr in
|
||||
if node.node_active then f node;
|
||||
loop node.node_prev
|
||||
end
|
||||
in
|
||||
loop seq.prev
|
||||
|
||||
let fold_l f seq acc =
|
||||
let rec loop curr acc =
|
||||
if curr == seq then
|
||||
acc
|
||||
else
|
||||
let node = node_of_seq curr in
|
||||
if node.node_active then
|
||||
loop node.node_next (f node.node_data acc)
|
||||
else
|
||||
loop node.node_next acc
|
||||
in
|
||||
loop seq.next acc
|
||||
|
||||
let fold_r f seq acc =
|
||||
let rec loop curr acc =
|
||||
if curr == seq then
|
||||
acc
|
||||
else
|
||||
let node = node_of_seq curr in
|
||||
if node.node_active then
|
||||
loop node.node_prev (f node.node_data acc)
|
||||
else
|
||||
loop node.node_next acc
|
||||
in
|
||||
loop seq.prev acc
|
|
@ -0,0 +1,137 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Interface Lwt_sequence
|
||||
* Copyright (C) 2009 Jérémie Dimino
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
(** Mutable sequence of elements *)
|
||||
|
||||
(** A sequence is an object holding a list of elements which support
|
||||
the following operations:
|
||||
|
||||
- adding an element to the left or the right in time and space O(1)
|
||||
- taking an element from the left or the right in time and space O(1)
|
||||
- removing a previously added element from a sequence in time and space O(1)
|
||||
- removing an element while the sequence is being transversed.
|
||||
*)
|
||||
|
||||
type 'a t
|
||||
(** Type of a sequence holding values of type ['a] *)
|
||||
|
||||
type 'a node
|
||||
(** Type of a node holding one value of type ['a] in a sequence *)
|
||||
|
||||
(** {6 Operation on nodes} *)
|
||||
|
||||
val get : 'a node -> 'a
|
||||
(** Returns the contents of a node *)
|
||||
|
||||
val set : 'a node -> 'a -> unit
|
||||
(** Change the contents of a node *)
|
||||
|
||||
val remove : 'a node -> unit
|
||||
(** Removes a node from the sequence it is part of. It does nothing
|
||||
if the node has already been removed. *)
|
||||
|
||||
(** {6 Operations on sequence} *)
|
||||
|
||||
val create : unit -> 'a t
|
||||
(** [create ()] creates a new empty sequence *)
|
||||
|
||||
val is_empty : 'a t -> bool
|
||||
(** Returns [true] iff the given sequence is empty *)
|
||||
|
||||
val length : 'a t -> int
|
||||
(** Returns the number of elemenets in the given sequence. This is a
|
||||
O(n) operation where [n] is the number of elements in the
|
||||
sequence. *)
|
||||
|
||||
val add_l : 'a -> 'a t -> 'a node
|
||||
(** [add_l x s] adds [x] to the left of the sequence [s] *)
|
||||
|
||||
val add_r : 'a -> 'a t -> 'a node
|
||||
(** [add_l x s] adds [x] to the right of the sequence [s] *)
|
||||
|
||||
exception Empty
|
||||
(** Exception raised by [take_l] and [tale_s] and when the sequence
|
||||
is empty *)
|
||||
|
||||
val take_l : 'a t -> 'a
|
||||
(** [take_l x s] remove and returns the leftmost element of [s]
|
||||
|
||||
@raise Empty if the sequence is empty *)
|
||||
|
||||
val take_r : 'a t -> 'a
|
||||
(** [take_l x s] remove and returns the rightmost element of [s]
|
||||
|
||||
@raise Empty if the sequence is empty *)
|
||||
|
||||
val take_opt_l : 'a t -> 'a option
|
||||
(** [take_opt_l x s] remove and returns [Some x] where [x] is the
|
||||
leftmost element of [s] or [None] if [s] is empty *)
|
||||
|
||||
val take_opt_r : 'a t -> 'a option
|
||||
(** [take_opt_l x s] remove and returns [Some x] where [x] is the
|
||||
rightmost element of [s] or [None] if [s] is empty *)
|
||||
|
||||
val transfer_l : 'a t -> 'a t -> unit
|
||||
(** [transfer_l s1 s2] removes all elements of [s1] and add them at
|
||||
the left of [s2]. This operation runs in constant time and
|
||||
space. *)
|
||||
|
||||
val transfer_r : 'a t -> 'a t -> unit
|
||||
(** [transfer_r s1 s2] removes all elements of [s1] and add them at
|
||||
the right of [s2]. This operation runs in constant time and
|
||||
space. *)
|
||||
|
||||
(** {6 Sequence iterators} *)
|
||||
|
||||
(** Note: it is OK to remove a node while traversing a sequence *)
|
||||
|
||||
val iter_l : ('a -> unit) -> 'a t -> unit
|
||||
(** [iter_l f s] applies [f] on all elements of [s] starting from
|
||||
the left *)
|
||||
|
||||
val iter_r : ('a -> unit) -> 'a t -> unit
|
||||
(** [iter_l f s] applies [f] on all elements of [s] starting from
|
||||
the right *)
|
||||
|
||||
val iter_node_l : ('a node -> unit) -> 'a t -> unit
|
||||
(** [iter_l f s] applies [f] on all nodes of [s] starting from
|
||||
the left *)
|
||||
|
||||
val iter_node_r : ('a node -> unit) -> 'a t -> unit
|
||||
(** [iter_l f s] applies [f] on all nodes of [s] starting from
|
||||
the right *)
|
||||
|
||||
val fold_l : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
|
||||
(** [fold_l f s] is:
|
||||
{[
|
||||
fold_l f s x = f en (... (f e2 (f e1 x)))
|
||||
]}
|
||||
where [e1], [e2], ..., [en] are the elements of [s]
|
||||
*)
|
||||
|
||||
val fold_r : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
|
||||
(** [fold_r f s] is:
|
||||
{[
|
||||
fold_r f s x = f e1 (f e2 (... (f en x)))
|
||||
]}
|
||||
where [e1], [e2], ..., [en] are the elements of [s]
|
||||
*)
|
|
@ -0,0 +1,759 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Module Lwt_stream
|
||||
* Copyright (C) 2009 Jérémie Dimino
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
open Lwt
|
||||
|
||||
exception Empty
|
||||
|
||||
type 'a t = {
|
||||
next : unit -> 'a option Lwt.t;
|
||||
(* The source of the stream *)
|
||||
queue : 'a option Queue.t;
|
||||
(* Queue of pending elements, which are not yet consumed *)
|
||||
clones : 'a option Queue.t Weak.t ref;
|
||||
(* List of queues of all clones of this event (including this
|
||||
event) *)
|
||||
mutex : Lwt_mutex.t;
|
||||
(* Mutex to prevent concurrent access to [next] *)
|
||||
}
|
||||
|
||||
let add_clone wa q =
|
||||
let len = Weak.length !wa in
|
||||
(* loop search for a free cell in [wa] and fill it with [q]: *)
|
||||
let rec loop i =
|
||||
if i = len then begin
|
||||
(* Growing *)
|
||||
let clones = Weak.create (len + 1) in
|
||||
Weak.blit !wa 0 clones 0 len;
|
||||
wa := clones;
|
||||
Weak.set clones len (Some q)
|
||||
end else if Weak.check !wa i then
|
||||
loop (i + 1)
|
||||
else
|
||||
Weak.set !wa i (Some q)
|
||||
in
|
||||
loop 0
|
||||
|
||||
let clone s =
|
||||
let s' = {
|
||||
next = s.next;
|
||||
queue = Queue.copy s.queue;
|
||||
clones = s.clones;
|
||||
mutex = s.mutex;
|
||||
} in
|
||||
add_clone s'.clones s'.queue;
|
||||
s'
|
||||
|
||||
let from f =
|
||||
let s = {
|
||||
next = f;
|
||||
queue = Queue.create ();
|
||||
clones = ref(Weak.create 1);
|
||||
mutex = Lwt_mutex.create ();
|
||||
} in
|
||||
Weak.set !(s.clones) 0 (Some s.queue);
|
||||
s
|
||||
|
||||
let of_list l =
|
||||
let l = ref l in
|
||||
from (fun () ->
|
||||
match !l with
|
||||
| [] -> return None
|
||||
| x :: l' -> l := l'; return (Some x))
|
||||
|
||||
let of_array a =
|
||||
let len = Array.length a and i = ref 0 in
|
||||
from (fun () ->
|
||||
if !i = len then
|
||||
return None
|
||||
else begin
|
||||
let c = Array.unsafe_get a !i in
|
||||
incr i;
|
||||
return (Some c)
|
||||
end)
|
||||
|
||||
let of_string s =
|
||||
let len = String.length s and i = ref 0 in
|
||||
from (fun () ->
|
||||
if !i = len then
|
||||
return None
|
||||
else begin
|
||||
let c = String.unsafe_get s !i in
|
||||
incr i;
|
||||
return (Some c)
|
||||
end)
|
||||
|
||||
module EQueue :
|
||||
sig
|
||||
type 'a t
|
||||
val create : unit -> 'a t * ('a option -> unit)
|
||||
val pop : 'a t -> 'a option Lwt.t
|
||||
end =
|
||||
struct
|
||||
type 'a state =
|
||||
| No_mail
|
||||
| Waiting of 'a option Lwt.u
|
||||
| Full of 'a option Queue.t
|
||||
|
||||
type 'a t = {
|
||||
mutable state : 'a state;
|
||||
}
|
||||
|
||||
let create () =
|
||||
let box = { state = No_mail } in
|
||||
let weak_box = Weak.create 1 in
|
||||
Weak.set weak_box 0 (Some box);
|
||||
let push v =
|
||||
match Weak.get weak_box 0 with
|
||||
| None -> ()
|
||||
| Some box ->
|
||||
match box.state with
|
||||
| No_mail ->
|
||||
let q = Queue.create () in
|
||||
Queue.push v q;
|
||||
box.state <- Full q
|
||||
| Waiting wakener ->
|
||||
box.state <- No_mail;
|
||||
wakeup_later wakener v
|
||||
| Full q ->
|
||||
Queue.push v q
|
||||
in
|
||||
(box, push)
|
||||
|
||||
let pop b = match b.state with
|
||||
| No_mail ->
|
||||
let waiter, wakener = task () in
|
||||
Lwt.on_cancel waiter (fun () -> b.state <- No_mail);
|
||||
b.state <- Waiting wakener;
|
||||
waiter
|
||||
| Waiting _ ->
|
||||
(* Calls to next are serialized, so this case will never
|
||||
happened *)
|
||||
assert false
|
||||
| Full q ->
|
||||
let v = Queue.take q in
|
||||
if Queue.is_empty q then b.state <- No_mail;
|
||||
return v
|
||||
end
|
||||
|
||||
let create () =
|
||||
let box, push = EQueue.create () in
|
||||
(from (fun () -> EQueue.pop box), push)
|
||||
|
||||
let push_clones wa x =
|
||||
for i = 0 to Weak.length wa - 1 do
|
||||
match Weak.get wa i with
|
||||
| Some q ->
|
||||
Queue.push x q
|
||||
| None ->
|
||||
()
|
||||
done
|
||||
|
||||
let peek s =
|
||||
if Queue.is_empty s.queue then
|
||||
Lwt_mutex.with_lock s.mutex begin fun () ->
|
||||
if Queue.is_empty s.queue then begin
|
||||
lwt result = s.next () in
|
||||
push_clones !(s.clones) result;
|
||||
return result
|
||||
end else
|
||||
return (Queue.top s.queue)
|
||||
end
|
||||
else
|
||||
return (Queue.top s.queue)
|
||||
|
||||
let rec force n s =
|
||||
if Queue.length s.queue >= n then
|
||||
return ()
|
||||
else
|
||||
Lwt_mutex.with_lock s.mutex begin fun () ->
|
||||
if Queue.length s.queue >= n then
|
||||
return false
|
||||
else begin
|
||||
lwt result = s.next () in
|
||||
push_clones !(s.clones) result;
|
||||
if result = None then
|
||||
return false
|
||||
else
|
||||
return true
|
||||
end
|
||||
end >>= function
|
||||
| true ->
|
||||
force n s
|
||||
| false ->
|
||||
return ()
|
||||
|
||||
let npeek n s =
|
||||
lwt () = force n s in
|
||||
let l, _ =
|
||||
Queue.fold
|
||||
(fun (l, n) x ->
|
||||
if n > 0 then
|
||||
match x with
|
||||
| Some x -> (x :: l, n - 1)
|
||||
| None -> (l, n)
|
||||
else
|
||||
(l, n))
|
||||
([], n) s.queue
|
||||
in
|
||||
return (List.rev l)
|
||||
|
||||
let rec get s =
|
||||
if Queue.is_empty s.queue then
|
||||
Lwt_mutex.with_lock s.mutex begin fun () ->
|
||||
if Queue.is_empty s.queue then begin
|
||||
lwt x = s.next () in
|
||||
(* This prevent from calling s.next when the stream has
|
||||
terminated: *)
|
||||
if x = None then Queue.push None s.queue;
|
||||
let wa = !(s.clones) in
|
||||
for i = 0 to Weak.length wa - 1 do
|
||||
match Weak.get wa i with
|
||||
| Some q when q != s.queue ->
|
||||
Queue.push x q
|
||||
| _ ->
|
||||
()
|
||||
done;
|
||||
return x
|
||||
end else begin
|
||||
let x = Queue.take s.queue in
|
||||
if x = None then Queue.push None s.queue;
|
||||
return x
|
||||
end
|
||||
end
|
||||
else begin
|
||||
let x = Queue.take s.queue in
|
||||
if x = None then Queue.push None s.queue;
|
||||
return x
|
||||
end
|
||||
|
||||
let nget n s =
|
||||
let rec loop n =
|
||||
if n <= 0 then
|
||||
return []
|
||||
else
|
||||
get s >>= function
|
||||
| Some x ->
|
||||
lwt l = loop (n - 1) in
|
||||
return (x :: l)
|
||||
| None ->
|
||||
return []
|
||||
in
|
||||
loop n
|
||||
|
||||
let get_while f s =
|
||||
let rec loop () =
|
||||
peek s >>= function
|
||||
| Some x ->
|
||||
let test = f x in
|
||||
if test then begin
|
||||
ignore (Queue.take s.queue);
|
||||
lwt l = loop () in
|
||||
return (x :: l)
|
||||
end else
|
||||
return []
|
||||
| None ->
|
||||
return []
|
||||
in
|
||||
loop ()
|
||||
|
||||
let get_while_s f s =
|
||||
let rec loop () =
|
||||
peek s >>= function
|
||||
| Some x ->
|
||||
lwt test = f x in
|
||||
if test then begin
|
||||
ignore (Queue.take s.queue);
|
||||
lwt l = loop () in
|
||||
return (x :: l)
|
||||
end else
|
||||
return []
|
||||
| None ->
|
||||
return []
|
||||
in
|
||||
loop ()
|
||||
|
||||
let next s = get s >>= function
|
||||
| Some x -> return x
|
||||
| None -> raise_lwt Empty
|
||||
|
||||
let last_new s =
|
||||
match Lwt.state (peek s) with
|
||||
| Return None ->
|
||||
raise_lwt Empty
|
||||
| Sleep ->
|
||||
next s
|
||||
| Fail exn ->
|
||||
raise_lwt exn
|
||||
| Return(Some x) ->
|
||||
let _ = Queue.take s.queue in
|
||||
let rec loop last =
|
||||
match Lwt.state (peek s) with
|
||||
| Sleep | Return None ->
|
||||
return last
|
||||
| Return(Some x) ->
|
||||
let _ = Queue.take s.queue in
|
||||
loop x
|
||||
| Fail exn ->
|
||||
raise_lwt exn
|
||||
in
|
||||
loop x
|
||||
|
||||
let to_list s =
|
||||
let rec loop () =
|
||||
get s >>= function
|
||||
| Some x ->
|
||||
lwt l = loop () in
|
||||
return (x :: l)
|
||||
| None ->
|
||||
return []
|
||||
in
|
||||
loop ()
|
||||
|
||||
let to_string s =
|
||||
let buf = Buffer.create 42 in
|
||||
let rec loop () =
|
||||
get s >>= function
|
||||
| Some x ->
|
||||
Buffer.add_char buf x;
|
||||
loop ()
|
||||
| None ->
|
||||
return (Buffer.contents buf)
|
||||
in
|
||||
loop ()
|
||||
|
||||
let junk s =
|
||||
lwt _ = get s in
|
||||
return ()
|
||||
|
||||
let njunk n s =
|
||||
let rec loop n =
|
||||
if n <= 0 then
|
||||
return ()
|
||||
else
|
||||
lwt _ = get s in
|
||||
loop (n - 1)
|
||||
in
|
||||
loop n
|
||||
|
||||
let junk_while f s =
|
||||
let rec loop () =
|
||||
peek s >>= function
|
||||
| Some x ->
|
||||
let test = f x in
|
||||
if test then begin
|
||||
ignore (Queue.take s.queue);
|
||||
loop ()
|
||||
end else
|
||||
return ()
|
||||
| None ->
|
||||
return ()
|
||||
in
|
||||
loop ()
|
||||
|
||||
let junk_while_s f s =
|
||||
let rec loop () =
|
||||
peek s >>= function
|
||||
| Some x ->
|
||||
lwt test = f x in
|
||||
if test then begin
|
||||
ignore (Queue.take s.queue);
|
||||
loop ()
|
||||
end else
|
||||
return ()
|
||||
| None ->
|
||||
return ()
|
||||
in
|
||||
loop ()
|
||||
|
||||
let junk_old s =
|
||||
let rec loop () =
|
||||
match Lwt.state (peek s) with
|
||||
| Sleep ->
|
||||
return ()
|
||||
| _ ->
|
||||
ignore (Queue.take s.queue);
|
||||
loop ()
|
||||
in
|
||||
loop ()
|
||||
|
||||
let get_available s =
|
||||
let rec loop () =
|
||||
match Lwt.state (peek s) with
|
||||
| Sleep | Return None ->
|
||||
[]
|
||||
| Return(Some x) ->
|
||||
ignore (Queue.take s.queue);
|
||||
x :: loop ()
|
||||
| Fail exn ->
|
||||
raise exn
|
||||
in
|
||||
loop ()
|
||||
|
||||
let get_available_up_to n s =
|
||||
let rec loop = function
|
||||
| 0 ->
|
||||
[]
|
||||
| n ->
|
||||
match Lwt.state (peek s) with
|
||||
| Sleep | Return None ->
|
||||
[]
|
||||
| Return(Some x) ->
|
||||
ignore (Queue.take s.queue);
|
||||
x :: loop (n - 1)
|
||||
| Fail exn ->
|
||||
raise exn
|
||||
in
|
||||
loop n
|
||||
|
||||
let is_empty s = peek s >|= fun x -> x = None
|
||||
|
||||
let map f s =
|
||||
from (fun () -> get s >>= function
|
||||
| Some x ->
|
||||
let x = f x in
|
||||
return (Some x)
|
||||
| None ->
|
||||
return None)
|
||||
|
||||
let map_s f s =
|
||||
from (fun () -> get s >>= function
|
||||
| Some x ->
|
||||
lwt x = f x in
|
||||
return (Some x)
|
||||
| None ->
|
||||
return None)
|
||||
|
||||
let filter f s =
|
||||
let rec next () =
|
||||
get s >>= function
|
||||
| Some x as result ->
|
||||
let test = f x in
|
||||
if test then
|
||||
return result
|
||||
else
|
||||
next ()
|
||||
| None ->
|
||||
return None
|
||||
in
|
||||
from next
|
||||
|
||||
let filter_s f s =
|
||||
let rec next () =
|
||||
get s >>= function
|
||||
| Some x as result ->
|
||||
lwt test = f x in
|
||||
if test then
|
||||
return result
|
||||
else
|
||||
next ()
|
||||
| None ->
|
||||
return None
|
||||
in
|
||||
from next
|
||||
|
||||
let filter_map f s =
|
||||
let rec next () =
|
||||
get s >>= function
|
||||
| Some x ->
|
||||
let x = f x in
|
||||
(match x with
|
||||
| Some _ ->
|
||||
return x
|
||||
| None ->
|
||||
next ())
|
||||
| None ->
|
||||
return None
|
||||
in
|
||||
from next
|
||||
|
||||
let filter_map_s f s =
|
||||
let rec next () =
|
||||
get s >>= function
|
||||
| Some x ->
|
||||
lwt x = f x in
|
||||
(match x with
|
||||
| Some _ ->
|
||||
return x
|
||||
| None ->
|
||||
next ())
|
||||
| None ->
|
||||
return None
|
||||
in
|
||||
from next
|
||||
|
||||
let map_list f s =
|
||||
let pendings = ref [] in
|
||||
let rec next () =
|
||||
match !pendings with
|
||||
| [] ->
|
||||
get s >>= (function
|
||||
| Some x ->
|
||||
let l = f x in
|
||||
pendings := l;
|
||||
next ()
|
||||
| None ->
|
||||
return None)
|
||||
| x :: l ->
|
||||
pendings := l;
|
||||
return (Some x)
|
||||
in
|
||||
from next
|
||||
|
||||
let map_list_s f s =
|
||||
let pendings = ref [] in
|
||||
let rec next () =
|
||||
match !pendings with
|
||||
| [] ->
|
||||
get s >>= (function
|
||||
| Some x ->
|
||||
lwt l = f x in
|
||||
pendings := l;
|
||||
next ()
|
||||
| None ->
|
||||
return None)
|
||||
| x :: l ->
|
||||
pendings := l;
|
||||
return (Some x)
|
||||
in
|
||||
from next
|
||||
|
||||
let flatten s =
|
||||
map_list (fun l -> l) s
|
||||
|
||||
let fold f s acc =
|
||||
let rec loop acc =
|
||||
get s >>= function
|
||||
| Some x ->
|
||||
let acc = f x acc in
|
||||
loop acc
|
||||
| None ->
|
||||
return acc
|
||||
in
|
||||
loop acc
|
||||
|
||||
let fold_s f s acc =
|
||||
let rec loop acc =
|
||||
get s >>= function
|
||||
| Some x ->
|
||||
lwt acc = f x acc in
|
||||
loop acc
|
||||
| None ->
|
||||
return acc
|
||||
in
|
||||
loop acc
|
||||
|
||||
let iter f s =
|
||||
let rec loop () =
|
||||
get s >>= function
|
||||
| Some x ->
|
||||
let () = f x in
|
||||
loop ()
|
||||
| None ->
|
||||
return ()
|
||||
in
|
||||
loop ()
|
||||
|
||||
let iter_s f s =
|
||||
let rec loop () =
|
||||
get s >>= function
|
||||
| Some x ->
|
||||
lwt () = f x in
|
||||
loop ()
|
||||
| None ->
|
||||
return ()
|
||||
in
|
||||
loop ()
|
||||
|
||||
let iter_p f s =
|
||||
let rec loop () =
|
||||
get s >>= function
|
||||
| Some x ->
|
||||
f x <&> loop ()
|
||||
| None ->
|
||||
return ()
|
||||
in
|
||||
loop ()
|
||||
|
||||
let find f s =
|
||||
let rec loop () =
|
||||
get s >>= function
|
||||
| Some x as result ->
|
||||
let test = f x in
|
||||
if test then
|
||||
return result
|
||||
else
|
||||
loop ()
|
||||
| None ->
|
||||
return None
|
||||
in
|
||||
loop ()
|
||||
|
||||
let find_s f s =
|
||||
let rec loop () =
|
||||
get s >>= function
|
||||
| Some x as result ->
|
||||
lwt test = f x in
|
||||
if test then
|
||||
return result
|
||||
else
|
||||
loop ()
|
||||
| None ->
|
||||
return None
|
||||
in
|
||||
loop ()
|
||||
|
||||
let rec find_map f s =
|
||||
let rec loop () =
|
||||
get s >>= function
|
||||
| Some x ->
|
||||
let x = f x in
|
||||
(match x with
|
||||
| Some _ ->
|
||||
return x
|
||||
| None ->
|
||||
loop ())
|
||||
| None ->
|
||||
return None
|
||||
in
|
||||
loop ()
|
||||
|
||||
let rec find_map_s f s =
|
||||
let rec loop () =
|
||||
get s >>= function
|
||||
| Some x ->
|
||||
lwt x = f x in
|
||||
(match x with
|
||||
| Some _ ->
|
||||
return x
|
||||
| None ->
|
||||
loop ())
|
||||
| None ->
|
||||
return None
|
||||
in
|
||||
loop ()
|
||||
|
||||
let rec combine s1 s2 =
|
||||
let next () =
|
||||
lwt n1 = get s1 and n2 = get s2 in
|
||||
match n1, n2 with
|
||||
| Some x1, Some x2 ->
|
||||
return (Some(x1, x2))
|
||||
| _ ->
|
||||
return None
|
||||
in
|
||||
from next
|
||||
|
||||
let append s1 s2 =
|
||||
let current_s = ref s1 and s1_finished = ref false in
|
||||
let rec next () =
|
||||
get !current_s >>= function
|
||||
| Some _ as result ->
|
||||
return result
|
||||
| None ->
|
||||
if !s1_finished then
|
||||
return None
|
||||
else begin
|
||||
s1_finished := true;
|
||||
current_s := s2;
|
||||
next ()
|
||||
end
|
||||
in
|
||||
from next
|
||||
|
||||
let concat s_top =
|
||||
let current_s = ref(from(fun () -> return None)) in
|
||||
let rec next () =
|
||||
get !current_s >>= function
|
||||
| Some _ as result ->
|
||||
return result
|
||||
| None ->
|
||||
get s_top >>= function
|
||||
| Some s ->
|
||||
current_s := s;
|
||||
next ()
|
||||
| None ->
|
||||
return None
|
||||
in
|
||||
from next
|
||||
|
||||
let choose streams =
|
||||
let source s = (s, peek s >|= fun x -> (s, x)) in
|
||||
let streams = ref (List.rev_map source streams) in
|
||||
let rec next () =
|
||||
match !streams with
|
||||
| [] ->
|
||||
return None
|
||||
| l ->
|
||||
lwt s, x = Lwt.choose (List.map snd l) in
|
||||
let l = List.remove_assq s l in
|
||||
match x with
|
||||
| Some _ ->
|
||||
lwt () = junk s in
|
||||
streams := source s :: l;
|
||||
return x
|
||||
| None ->
|
||||
next ()
|
||||
in
|
||||
from next
|
||||
|
||||
let parse s f =
|
||||
let s' = clone s in
|
||||
try_lwt
|
||||
f s
|
||||
with exn ->
|
||||
Queue.clear s.queue;
|
||||
Queue.transfer s'.queue s.queue;
|
||||
raise_lwt exn
|
||||
|
||||
let hexdump stream =
|
||||
let buf = Buffer.create 80 and num = ref 0 in
|
||||
from begin fun _ ->
|
||||
nget 16 stream >>= function
|
||||
| [] ->
|
||||
return None
|
||||
| l ->
|
||||
Buffer.clear buf;
|
||||
Printf.bprintf buf "%08x| " !num;
|
||||
num := !num + 16;
|
||||
let rec bytes pos = function
|
||||
| [] ->
|
||||
blanks pos
|
||||
| x :: l ->
|
||||
if pos = 8 then Buffer.add_char buf ' ';
|
||||
Printf.bprintf buf "%02x " (Char.code x);
|
||||
bytes (pos + 1) l
|
||||
and blanks pos =
|
||||
if pos < 16 then begin
|
||||
if pos = 8 then
|
||||
Buffer.add_string buf " "
|
||||
else
|
||||
Buffer.add_string buf " ";
|
||||
blanks (pos + 1)
|
||||
end
|
||||
in
|
||||
bytes 0 l;
|
||||
Buffer.add_string buf " |";
|
||||
List.iter (fun ch -> Buffer.add_char buf (if ch >= '\x20' && ch <= '\x7e' then ch else '.')) l;
|
||||
Buffer.add_char buf '|';
|
||||
return (Some(Buffer.contents buf))
|
||||
end
|
|
@ -0,0 +1,242 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Module Lwt_stream
|
||||
* Copyright (C) 2009 Jérémie Dimino
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
(** Data streams *)
|
||||
|
||||
type 'a t
|
||||
(** Type of a stream holding values of type ['a] *)
|
||||
|
||||
(** Naming convention: in this module all function taking a function
|
||||
which is applied to all element of the streams are suffixed by:
|
||||
|
||||
- [_s] when the function returns a thread and calls are serialised
|
||||
- [_p] when the function returns a thread and calls are parallelised
|
||||
*)
|
||||
|
||||
(** {6 Construction} *)
|
||||
|
||||
val from : (unit -> 'a option Lwt.t) -> 'a t
|
||||
(** [from f] creates an stream from the given input function. [f] is
|
||||
called each time more input is needed, and the stream ends when
|
||||
[f] returns [None]. *)
|
||||
|
||||
val create : unit -> 'a t * ('a option -> unit)
|
||||
(** [create ()] returns a new stream and a push function *)
|
||||
|
||||
val of_list : 'a list -> 'a t
|
||||
(** [of_list l] creates a stream returning all elements of [l] *)
|
||||
|
||||
val of_array : 'a array -> 'a t
|
||||
(** [of_array a] creates a stream returning all elements of [a] *)
|
||||
|
||||
val of_string : string -> char t
|
||||
(** [of_string str] creates a stream returning all characters of
|
||||
[str] *)
|
||||
|
||||
val clone : 'a t -> 'a t
|
||||
(** [clone st] clone the given stream. Operations on each stream
|
||||
will not affect the other.
|
||||
|
||||
For example:
|
||||
|
||||
{[
|
||||
# let st1 = Lwt_stream.of_list [1; 2; 3];;
|
||||
val st1 : int Lwt_stream.t = <abstr>
|
||||
# let st2 = Lwt_stream.clone st1;;
|
||||
val st2 : int Lwt_stream.t = <abstr>
|
||||
# lwt x = Lwt_stream.next st1;;
|
||||
val x : int = 1
|
||||
# lwt y = Lwt_stream.next st2;;
|
||||
val y : int = 1
|
||||
]}
|
||||
*)
|
||||
|
||||
(** {6 Destruction} *)
|
||||
|
||||
val to_list : 'a t -> 'a list Lwt.t
|
||||
(** Returns the list of elements of the given stream *)
|
||||
|
||||
val to_string : char t -> string Lwt.t
|
||||
(** Returns the word composed of all characters of the given
|
||||
stream *)
|
||||
|
||||
(** {6 Data retreival} *)
|
||||
|
||||
exception Empty
|
||||
(** Exception raised when trying to retreive data from an empty
|
||||
stream. *)
|
||||
|
||||
val peek : 'a t -> 'a option Lwt.t
|
||||
(** [peek st] returns the first element of the stream, if any,
|
||||
without removing it. *)
|
||||
|
||||
val npeek : int -> 'a t -> 'a list Lwt.t
|
||||
(** [npeek n st] returns at most the first [n] elements of [st],
|
||||
without removing them. *)
|
||||
|
||||
val get : 'a t -> 'a option Lwt.t
|
||||
(** [get st] remove and returns the first element of the stream, if
|
||||
any. *)
|
||||
|
||||
val nget : int -> 'a t -> 'a list Lwt.t
|
||||
(** [nget n st] remove and returns at most the first [n] elements of
|
||||
[st]. *)
|
||||
|
||||
val get_while : ('a -> bool) -> 'a t -> 'a list Lwt.t
|
||||
val get_while_s : ('a -> bool Lwt.t) -> 'a t -> 'a list Lwt.t
|
||||
(** [get_while f st] returns the longest prefix of [st] where all
|
||||
elements satisfy [f]. *)
|
||||
|
||||
val next : 'a t -> 'a Lwt.t
|
||||
(** [next st] remove and returns the next element of the stream, of
|
||||
fail with {!Empty} if the stream is empty. *)
|
||||
|
||||
val last_new : 'a t -> 'a Lwt.t
|
||||
(** [next_new st] if no element are available on [st] without
|
||||
sleeping, then it is the same as [next st]. Otherwise it removes
|
||||
all elements of [st] that are ready except the last one, and
|
||||
return it.
|
||||
|
||||
If fails with {!Empty} if the stream has no more elements *)
|
||||
|
||||
val junk : 'a t -> unit Lwt.t
|
||||
(** [junk st] remove the first element of [st]. *)
|
||||
|
||||
val njunk : int -> 'a t -> unit Lwt.t
|
||||
(** [njunk n st] removes at most the first [n] elements of the
|
||||
stream. *)
|
||||
|
||||
val junk_while : ('a -> bool) -> 'a t -> unit Lwt.t
|
||||
val junk_while_s : ('a -> bool Lwt.t) -> 'a t -> unit Lwt.t
|
||||
(** [junk_while f st] removes all elements at the beginning of the
|
||||
streams which satisfy [f]. *)
|
||||
|
||||
val junk_old : 'a t -> unit Lwt.t
|
||||
(** [junk_old st] removes all elements that are ready to be read
|
||||
without yeilding from [st].
|
||||
|
||||
For example the [read_password] function of [Lwt_read_line] use
|
||||
that to junk key previously typed by the user.
|
||||
*)
|
||||
|
||||
val get_available : 'a t -> 'a list
|
||||
(** [get_available l] returns all available elements of [l] without
|
||||
blocking *)
|
||||
|
||||
val get_available_up_to : int -> 'a t -> 'a list
|
||||
(** [get_available_up_to l n] returns up to [n] elements of [l]
|
||||
without blocking *)
|
||||
|
||||
val is_empty : 'a t -> bool Lwt.t
|
||||
(** [is_empty enum] returns wether the given stream is empty *)
|
||||
|
||||
(** {6 Stream transversal} *)
|
||||
|
||||
(** Note: all the following functions are destructive.
|
||||
|
||||
For example:
|
||||
|
||||
{[
|
||||
# let st1 = Lwt_stream.of_list [1; 2; 3];;
|
||||
val st1 : int Lwt_stream.t = <abstr>
|
||||
# let st2 = Lwt_stream.map string_of_int st1;;
|
||||
val st2 : string Lwt_stream.t = <abstr>
|
||||
# lwt x = Lwt_stream.next st1;;
|
||||
val x : int = 1
|
||||
# lwt y = Lwt_stream.next st2;;
|
||||
val y : string = "2"
|
||||
]}
|
||||
*)
|
||||
|
||||
val choose : 'a t list -> 'a t
|
||||
(** [choose l] creates an stream from a list of streams. The
|
||||
resulting stream will returns elements returned by any stream of
|
||||
[l] in an unspecified order. *)
|
||||
|
||||
val map : ('a -> 'b) -> 'a t -> 'b t
|
||||
val map_s : ('a -> 'b Lwt.t) -> 'a t -> 'b t
|
||||
(** [map f st] maps the value returned by [st] with [f] *)
|
||||
|
||||
val filter : ('a -> bool) -> 'a t -> 'a t
|
||||
val filter_s : ('a -> bool Lwt.t) -> 'a t -> 'a t
|
||||
(** [filter f st] keeps only value [x] such that [f x] is [true] *)
|
||||
|
||||
val filter_map : ('a -> 'b option) -> 'a t -> 'b t
|
||||
val filter_map_s : ('a -> 'b option Lwt.t) -> 'a t -> 'b t
|
||||
(** [filter_map f st] filter and map [st] at the same time *)
|
||||
|
||||
val map_list : ('a -> 'b list) -> 'a t -> 'b t
|
||||
val map_list_s : ('a -> 'b list Lwt.t) -> 'a t -> 'b t
|
||||
(** [map_list f st] applies [f] on each element of [st] and flattens
|
||||
the lists returned *)
|
||||
|
||||
val fold : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b Lwt.t
|
||||
val fold_s : ('a -> 'b -> 'b Lwt.t) -> 'a t -> 'b -> 'b Lwt.t
|
||||
(** [fold f s x] fold_like function for streams. *)
|
||||
|
||||
val iter : ('a -> unit) -> 'a t -> unit Lwt.t
|
||||
val iter_p : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t
|
||||
val iter_s : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t
|
||||
(** [iter f s] iterates over all elements of the stream *)
|
||||
|
||||
val find : ('a -> bool) -> 'a t -> 'a option Lwt.t
|
||||
val find_s : ('a -> bool Lwt.t) -> 'a t -> 'a option Lwt.t
|
||||
(** [find f s] find an element in a stream. *)
|
||||
|
||||
val find_map : ('a -> 'b option) -> 'a t -> 'b option Lwt.t
|
||||
val find_map_s : ('a -> 'b option Lwt.t) -> 'a t -> 'b option Lwt.t
|
||||
(** [find f s] find and map at the same time. *)
|
||||
|
||||
val combine : 'a t -> 'b t -> ('a * 'b) t
|
||||
(** [combine s1 s2] combine two streams. The stream will ends when
|
||||
the first stream ends. *)
|
||||
|
||||
val append : 'a t -> 'a t -> 'a t
|
||||
(** [append s1 s2] returns a stream which returns all elements of
|
||||
[s1], then all elements of [s2] *)
|
||||
|
||||
val concat : 'a t t -> 'a t
|
||||
(** [concat st] returns the concatenation of all streams of [st]. *)
|
||||
|
||||
val flatten : 'a list t -> 'a t
|
||||
(** [flatten st = map_list (fun l -> l) st] *)
|
||||
|
||||
(** {6 Parsing} *)
|
||||
|
||||
val parse : 'a t -> ('a t -> 'b Lwt.t) -> 'b Lwt.t
|
||||
(** [parse st f] parses [st] with [f]. If [f] raise an exception,
|
||||
[st] is restored to its previous state. *)
|
||||
|
||||
(** {6 Misc} *)
|
||||
|
||||
val hexdump : char t -> string t
|
||||
(** [hexdump byte_stream] returns a stream which is the same as the
|
||||
output of [hexdump -C].
|
||||
|
||||
Basically, here is a simple implementation of [hexdump -C]:
|
||||
|
||||
{[
|
||||
open Lwt
|
||||
open Lwt_io
|
||||
let () = Lwt_main.run (write_lines stdout (Lwt_stream.hexdump (read_lines stdin)))
|
||||
]}
|
||||
*)
|
|
@ -0,0 +1,73 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Module Lwt_switch
|
||||
* Copyright (C) 2010 Jérémie Dimino
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
open Lwt
|
||||
|
||||
exception Off
|
||||
|
||||
type on_switch = {
|
||||
mutable hooks : (unit -> unit Lwt.t) list;
|
||||
}
|
||||
|
||||
type state =
|
||||
| St_on of on_switch
|
||||
| St_off
|
||||
|
||||
type t = { mutable state : state }
|
||||
|
||||
let create () = { state = St_on { hooks = [] } }
|
||||
|
||||
let is_on switch =
|
||||
match switch.state with
|
||||
| St_on _ -> true
|
||||
| St_off -> false
|
||||
|
||||
let check = function
|
||||
| Some{ state = St_off } -> raise Off
|
||||
| _ -> ()
|
||||
|
||||
let add_hook switch hook =
|
||||
match switch with
|
||||
| Some{ state = St_on os } ->
|
||||
os.hooks <- hook :: os.hooks
|
||||
| Some{ state = St_off } ->
|
||||
raise Off
|
||||
| None ->
|
||||
()
|
||||
|
||||
let add_hook_or_exec switch hook =
|
||||
match switch with
|
||||
| Some{ state = St_on os } ->
|
||||
os.hooks <- hook :: os.hooks;
|
||||
return ()
|
||||
| Some{ state = St_off } ->
|
||||
hook ()
|
||||
| None ->
|
||||
return ()
|
||||
|
||||
let turn_off switch =
|
||||
match switch.state with
|
||||
| St_on { hooks = hooks } ->
|
||||
switch.state <- St_off;
|
||||
Lwt_list.iter_p (fun hook -> apply hook ()) hooks
|
||||
| St_off ->
|
||||
return ()
|
|
@ -0,0 +1,111 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Interface Lwt_switch
|
||||
* Copyright (C) 2010 Jérémiem Dimino
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
(** Lwt switches *)
|
||||
|
||||
(** Switch have two goals:
|
||||
|
||||
- being able to free multiple resources at the same time,
|
||||
- offer a better alternative than always returning an id to free
|
||||
some resource.
|
||||
|
||||
For example, considers the following interface:
|
||||
|
||||
{[
|
||||
type id
|
||||
|
||||
val free : id -> unit Lwt.t
|
||||
|
||||
val f : unit -> id Lwt.t
|
||||
val g : unit -> id Lwt.t
|
||||
val h : unit -> id Lwt.t
|
||||
]}
|
||||
|
||||
Now you want to calls [f], [g] and [h] in parallel. You can
|
||||
simply do:
|
||||
|
||||
{[
|
||||
lwt idf = f () and idg = g () and idh = h () in
|
||||
...
|
||||
]}
|
||||
|
||||
However, one may wants to handle possible failures of [f ()], [g
|
||||
()] and [h ()], and disable all allocated resources if one of
|
||||
these three threads fails. This may be hard since you have to
|
||||
remember which one failed and which one returned correctly.
|
||||
|
||||
Now we change a little bit the interface:
|
||||
|
||||
{[
|
||||
val f : ?switch : Lwt_switch.t -> unit -> id Lwt.t
|
||||
val g : ?switch : Lwt_switch.t -> unit -> id Lwt.t
|
||||
val h : ?switch : Lwt_switch.t -> unit -> id Lwt.t
|
||||
]}
|
||||
|
||||
and the code becomes:
|
||||
|
||||
{[
|
||||
let switch = Lwt_switch.create () in
|
||||
try_lwt
|
||||
lwt idf = f ~switch () and idg = g ~switch () and idh = h ~switch () in
|
||||
...
|
||||
with exn ->
|
||||
lwt () = Lwt_switch.turn_off switch in
|
||||
raise_lwt exn
|
||||
]}
|
||||
*)
|
||||
|
||||
type t
|
||||
(** Type of switches. *)
|
||||
|
||||
val create : unit -> t
|
||||
(** [create ()] creates a new switch. *)
|
||||
|
||||
val is_on : t -> bool
|
||||
(** [is_on switch] returns [true] if the switch is currently on, and
|
||||
[false] otherwise. *)
|
||||
|
||||
val turn_off : t -> unit Lwt.t
|
||||
(** [turn_off switch] turns off the switch. It calls all registered
|
||||
hooks, waits for all of them to terminates, and the returns. If
|
||||
one of the hook failed, then it will fail with one of the
|
||||
exception raised by hooks. If the switch is already off, then it
|
||||
does nothing. *)
|
||||
|
||||
exception Off
|
||||
(** Exception raised when trying to add a hook to a switch that is
|
||||
already off. *)
|
||||
|
||||
val check : t option -> unit
|
||||
(** [check switch] does nothing if [switch] is [None] or contains an
|
||||
switch that is currently on, and raise {!Off} otherwise. *)
|
||||
|
||||
val add_hook : t option -> (unit -> unit Lwt.t) -> unit
|
||||
(** [add_hook switch f] registers [f] so it will be called when
|
||||
{!turn_off} is invoked. It does nothing if [switch] is
|
||||
[None]. If [switch] contains an switch that is already off then
|
||||
{!Off} is raised. *)
|
||||
|
||||
val add_hook_or_exec : t option -> (unit -> unit Lwt.t) -> unit Lwt.t
|
||||
(** [add_hook_or_exec switch f] is the same as {!add_hook} except
|
||||
that if the switch is already off, then [f] is called
|
||||
immediatly. *)
|
|
@ -0,0 +1,117 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Module Lwt_util
|
||||
* Copyright (C) 2005-2008 Jérôme Vouillon
|
||||
* Laboratoire PPS - CNRS Université Paris Diderot
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
open Lwt
|
||||
|
||||
let rec iter f l =
|
||||
let l = List.fold_left (fun acc a -> f a :: acc) [] l in
|
||||
let l = List.rev l in
|
||||
List.fold_left (fun rt t -> t >>= fun () -> rt) (Lwt.return ()) l
|
||||
|
||||
let rec iter_serial f l =
|
||||
match l with
|
||||
[] -> return ()
|
||||
| a :: r -> f a >>= (fun () -> iter_serial f r)
|
||||
|
||||
let rec map f l =
|
||||
match l with
|
||||
[] ->
|
||||
return []
|
||||
| v :: r ->
|
||||
let t = f v in
|
||||
let rt = map f r in
|
||||
t >>= (fun v' ->
|
||||
rt >>= (fun l' ->
|
||||
return (v' :: l')))
|
||||
|
||||
let map_with_waiting_action f wa l =
|
||||
let rec loop l =
|
||||
match l with
|
||||
[] ->
|
||||
return []
|
||||
| v :: r ->
|
||||
let t = f v in
|
||||
let rt = loop r in
|
||||
t >>= (fun v' ->
|
||||
(* Perform the specified "waiting action" for the next *)
|
||||
(* item in the list. *)
|
||||
if r <> [] then
|
||||
wa (List.hd r)
|
||||
else
|
||||
();
|
||||
rt >>= (fun l' ->
|
||||
return (v' :: l')))
|
||||
in
|
||||
if l <> [] then
|
||||
wa (List.hd l)
|
||||
else
|
||||
();
|
||||
loop l
|
||||
|
||||
let rec map_serial f l =
|
||||
match l with
|
||||
[] ->
|
||||
return []
|
||||
| v :: r ->
|
||||
f v >>= (fun v' ->
|
||||
map_serial f r >>= (fun l' ->
|
||||
return (v' :: l')))
|
||||
|
||||
let rec fold_left f a = function
|
||||
| [] -> return a
|
||||
| b::l -> f a b >>= fun v -> fold_left f v l
|
||||
|
||||
let join = Lwt.join
|
||||
|
||||
type region =
|
||||
{ mutable size : int;
|
||||
mutable count : int;
|
||||
waiters : (unit Lwt.u * int) Queue.t }
|
||||
|
||||
let make_region count = { size = count; count = 0; waiters = Queue.create () }
|
||||
|
||||
let resize_region reg sz = reg.size <- sz
|
||||
|
||||
let leave_region reg sz =
|
||||
try
|
||||
if reg.count - sz >= reg.size then raise Queue.Empty;
|
||||
let (w, sz') = Queue.take reg.waiters in
|
||||
reg.count <- reg.count - sz + sz';
|
||||
Lwt.wakeup_later w ()
|
||||
with Queue.Empty ->
|
||||
reg.count <- reg.count - sz
|
||||
|
||||
let run_in_region_1 reg sz thr =
|
||||
(catch
|
||||
(fun () -> thr () >>= (fun v -> leave_region reg sz; return v))
|
||||
(fun e -> leave_region reg sz; raise_lwt e))
|
||||
|
||||
let run_in_region reg sz thr =
|
||||
if reg.count >= reg.size then begin
|
||||
let (res, w) = wait () in
|
||||
Queue.add (w, sz) reg.waiters;
|
||||
res >>= (fun () -> run_in_region_1 reg sz thr)
|
||||
end else begin
|
||||
reg.count <- reg.count + sz;
|
||||
run_in_region_1 reg sz thr
|
||||
end
|
|
@ -0,0 +1,80 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Interface Lwt_util
|
||||
* Copyright (C) 2005-2008 Jérôme Vouillon
|
||||
* Laboratoire PPS - CNRS Université Paris Diderot
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
(** Note: This lodule is deprecated. Use {!Lwt_list} and {!Lwt_pool}
|
||||
instead. *)
|
||||
|
||||
(** {2 Lists iterators} *)
|
||||
|
||||
val iter : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t
|
||||
(** [iter f l] start a thread for each element in [l]. The threads
|
||||
are started according to the list order, but then can run
|
||||
concurrently. It terminates when all the threads are
|
||||
terminated, if all threads are successful. It fails if any of
|
||||
the threads fail. *)
|
||||
|
||||
val iter_serial : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t
|
||||
(** Similar to [iter] but wait for one thread to terminate before
|
||||
starting the next one. *)
|
||||
|
||||
val map : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t
|
||||
(** [map f l] apply [f] to each element in [l] and collect the
|
||||
results of the threads thus created. The threads are started
|
||||
according to the list order, but then can run concurrently.
|
||||
[map f l] fails if any of the threads fail. *)
|
||||
|
||||
val map_with_waiting_action :
|
||||
('a -> 'b Lwt.t) -> ('a -> unit) -> 'a list -> 'b list Lwt.t
|
||||
(** [map_with_waiting_action f wa l] apply [f] to each element
|
||||
in [l] and collect the results of the threads thus created.
|
||||
The threads are started according to the list order, but
|
||||
then can run concurrently. The difference with [map f l] is
|
||||
that function wa will be called on the element that the
|
||||
function is waiting for its termination. *)
|
||||
|
||||
val map_serial : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t
|
||||
(** Similar to [map] but wait for one thread to terminate before
|
||||
starting the next one. *)
|
||||
|
||||
val fold_left : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b list -> 'a Lwt.t
|
||||
(** Similar to [List.fold_left]. *)
|
||||
|
||||
(****)
|
||||
|
||||
(** {2 Regions} *)
|
||||
|
||||
type region
|
||||
|
||||
val make_region : int -> region
|
||||
(** [make_region sz] create a region of size [sz]. *)
|
||||
val resize_region : region -> int -> unit
|
||||
(** [resize_region reg sz] resize the region [reg] to size [sz]. *)
|
||||
val run_in_region : region -> int -> (unit -> 'a Lwt.t) -> 'a Lwt.t
|
||||
(** [run_in_region reg size f] execute the thread produced by the
|
||||
function [f] in the region [reg]. The thread is not started
|
||||
before some room is available in the region. *)
|
||||
|
||||
(**/**)
|
||||
|
||||
val join : unit Lwt.t list -> unit Lwt.t
|
||||
(** Same as [Lwt.join] *)
|
|
@ -0,0 +1,4 @@
|
|||
# OASIS_START
|
||||
# DO NOT EDIT (digest: 73d5d5d814da6fce812bc449a2dcd20c)
|
||||
Lwt_lib
|
||||
# OASIS_STOP
|
|
@ -0,0 +1,134 @@
|
|||
(* Ocsigen
|
||||
* http://www.ocsigen.org
|
||||
* lwt_lib.ml Copyright (C) 2007 Pierre Clairambault
|
||||
* Laboratoire PPS - CNRS Université Paris Diderot
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later version.
|
||||
* See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful,
|
||||
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
* GNU Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
*)
|
||||
|
||||
open Weak
|
||||
open Unix
|
||||
open Lwt
|
||||
|
||||
let switch_time = 30.
|
||||
|
||||
exception Not_in_table
|
||||
(* We use a specific Not_in_table exception, because since we're caching
|
||||
* threads, we can't for the moment behave differently whether a request
|
||||
* is not found in the table or not found as a host.*)
|
||||
|
||||
|
||||
module WeakHashtbl = Make(
|
||||
struct
|
||||
type t = string * (Unix.host_entry Lwt.t) * float
|
||||
let equal = (fun (a,b,c) -> fun (a',b',c') -> a=a')
|
||||
let hash = fun (a,b,c) -> Hashtbl.hash a
|
||||
end
|
||||
)
|
||||
|
||||
open WeakHashtbl
|
||||
|
||||
let keeper : (((string*(Unix.host_entry Lwt.t)*float) list) *
|
||||
((string*(Unix.host_entry Lwt.t)*float) list)) ref = ref ([],[])
|
||||
let cache = create 0
|
||||
let dummy_addr : Unix.host_entry =
|
||||
{h_name="dummy";
|
||||
h_aliases=[||];
|
||||
h_addrtype=Unix.PF_INET;
|
||||
h_addr_list = [||]}
|
||||
|
||||
let cache_find d = try
|
||||
match (find cache (d,return dummy_addr,0.)) with (_,h,t) -> (h,t)
|
||||
with
|
||||
|Not_found -> raise Not_in_table
|
||||
|e -> raise e
|
||||
|
||||
let gethostbyname d =
|
||||
Lwt.catch
|
||||
(fun _ ->
|
||||
let (h,t) = cache_find d
|
||||
and t' = Unix.time () in
|
||||
match (t'>t+.60.) with
|
||||
| true ->
|
||||
(remove cache) (d,h,t);
|
||||
raise_lwt Not_in_table
|
||||
| false -> h)
|
||||
(function
|
||||
| Not_in_table ->
|
||||
let t = Unix.time() and
|
||||
h = Lwt_preemptive.detach Unix.gethostbyname d in
|
||||
let entry = (d,h,t) in
|
||||
add cache entry;
|
||||
(match !keeper with (a,b) -> keeper:= (entry::a,b));
|
||||
h
|
||||
| e -> raise_lwt e)
|
||||
(* Begin getaddrinfo caching *)
|
||||
|
||||
|
||||
module WeakAddrInfo = Make(
|
||||
struct
|
||||
type t = string*string*(Unix.getaddrinfo_option list)*((Unix.addr_info list) Lwt.t)*float
|
||||
let equal = (fun (h,s,o,i,t) -> fun (h',s',o',i',t') -> (h,s,o)=(h',s',o'))
|
||||
let hash = fun (h,s,o,i,t) -> Hashtbl.hash (h,s,o)
|
||||
end
|
||||
)
|
||||
|
||||
let keeper6 : (((string*string*(Unix.getaddrinfo_option list)*((Unix.addr_info list) Lwt.t)*float) list) *
|
||||
((string*string*(Unix.getaddrinfo_option list)*((Unix.addr_info list) Lwt.t)*float) list)) ref = ref
|
||||
([],[])
|
||||
|
||||
let switch_thread : unit Lwt.t=
|
||||
let rec switch_worker () =
|
||||
Lwt_unix.sleep switch_time >>= fun () ->
|
||||
(match !keeper with (a,b) -> keeper:=([],a));
|
||||
(match !keeper6 with (a,b) -> keeper6:=([],a));
|
||||
switch_worker ()
|
||||
in
|
||||
switch_worker()
|
||||
|
||||
let cache6 = WeakAddrInfo.create 0
|
||||
|
||||
let cache_find6 d s o = try
|
||||
match (WeakAddrInfo.find cache6 (d,s,o,return [],0.)) with (_,_,_,i,t) -> (i,t)
|
||||
with
|
||||
|Not_found -> raise Not_in_table
|
||||
|e -> raise e
|
||||
|
||||
|
||||
let getaddrinfo d s o =
|
||||
Lwt.catch
|
||||
(fun _ ->
|
||||
let (i,t) = cache_find6 d s o
|
||||
and t' = Unix.time() in
|
||||
match (t'>t+.60.) with
|
||||
| true ->
|
||||
WeakAddrInfo.remove cache6 (d,s,o,i,t);
|
||||
raise_lwt Not_in_table
|
||||
| false -> i)
|
||||
(function
|
||||
| Not_in_table ->
|
||||
let t = Unix.time () and
|
||||
i = Lwt_preemptive.detach (Unix.getaddrinfo d s) o in
|
||||
let entry = (d,s,o,i,t) in
|
||||
WeakAddrInfo.add cache6 entry;
|
||||
(match !keeper6 with (a,b) -> keeper6 := (entry::a,b));
|
||||
i
|
||||
| e -> raise_lwt e)
|
||||
|
||||
|
||||
let getnameinfo s l =
|
||||
(*VVV à implémenter !!! *)
|
||||
Lwt_preemptive.detach (Unix.getnameinfo s) l
|
|
@ -0,0 +1,44 @@
|
|||
(* Ocsigen
|
||||
* http://www.ocsigen.org
|
||||
* lwt_lib.mli Copyright (C) 2007 Pierre Clairambault
|
||||
* Laboratoire PPS - CNRS Université Paris Diderot
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later version.
|
||||
* See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful,
|
||||
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
* GNU Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
*)
|
||||
|
||||
(** Cooperative unix system calls *)
|
||||
|
||||
(** This module transform non-cooperative functions of the standard
|
||||
library into cooperative ones by launching them into system
|
||||
threads.
|
||||
|
||||
Indeed, lots of functions of the [Unix] modules, corresponding to
|
||||
functions of the standard C library may take times to
|
||||
complete. For example [gethostbyname] may use DNS resolution,
|
||||
users informations may be stored in a ldap database, ...
|
||||
|
||||
Since these functions are implemented (in the standard C library)
|
||||
using blocking IOs, if you use them directly, you program may
|
||||
hang. *)
|
||||
|
||||
val getaddrinfo : string -> string -> Unix.getaddrinfo_option list -> Unix.addr_info list Lwt.t
|
||||
(** Cooperative getaddrinfo with cache (using Lwt_preemptive.detach) *)
|
||||
|
||||
val gethostbyname : string -> Unix.host_entry Lwt.t
|
||||
(** Cooperative gethostbyname with cache (using Lwt_preemptive.detach) *)
|
||||
|
||||
val getnameinfo : Unix.sockaddr -> Unix.getnameinfo_option list -> Unix.name_info Lwt.t
|
||||
(** Cooperative getnameinfo with cache (using Lwt_preemptive.detach) *)
|
|
@ -0,0 +1,4 @@
|
|||
# OASIS_START
|
||||
# DO NOT EDIT (digest: 905c14a6abfdc3cc49bbc233df66ff99)
|
||||
lwt_glib_stubs.o
|
||||
# OASIS_STOP
|
|
@ -0,0 +1,4 @@
|
|||
# OASIS_START
|
||||
# DO NOT EDIT (digest: dfe8b7bfa132aa66ad19dbdbf3bcbaaa)
|
||||
Lwt_glib
|
||||
# OASIS_STOP
|
|
@ -0,0 +1,132 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Module glib
|
||||
* Copyright (C) 2009-2011 Jérémie Dimino
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
type source = {
|
||||
fd : Unix.file_descr;
|
||||
check_readable : bool;
|
||||
check_writable : bool;
|
||||
}
|
||||
|
||||
external glib_init : unit -> unit = "lwt_glib_init"
|
||||
external glib_stop : unit -> unit = "lwt_glib_stop"
|
||||
|
||||
type state =
|
||||
| State_none
|
||||
| State_glib_into_lwt of (unit -> unit) Lwt_sequence.node * (unit -> unit) Lwt_sequence.node
|
||||
| State_lwt_into_glib of Lwt_engine.t
|
||||
|
||||
let state = ref State_none
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Glib-based engine |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
external glib_poll : (Unix.file_descr * bool * bool) list -> int -> int -> (Unix.file_descr * bool * bool) list = "lwt_glib_poll"
|
||||
|
||||
class engine = object
|
||||
inherit Lwt_engine.poll_based
|
||||
method private poll fds timeout = glib_poll fds (List.length fds) (truncate (timeout *. 1000.))
|
||||
end
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Glib --> Lwt based integration |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
external glib_get_sources : unit -> source array * float = "lwt_glib_get_sources"
|
||||
external glib_check : unit -> unit = "lwt_glib_check"
|
||||
external glib_mark_readable : int -> unit = "lwt_glib_mark_readable" "noalloc"
|
||||
external glib_mark_writable : int -> unit = "lwt_glib_mark_readable" "noalloc"
|
||||
|
||||
let events = ref []
|
||||
let check = ref true
|
||||
|
||||
let enter () =
|
||||
if !check then begin
|
||||
check := false;
|
||||
let engine = Lwt_engine.get () in
|
||||
assert (!events = []);
|
||||
let sources, timeout = glib_get_sources () in
|
||||
for i = 0 to Array.length sources - 1 do
|
||||
let src = sources.(i) in
|
||||
if src.check_readable then
|
||||
events := engine#on_readable src.fd (fun _ -> glib_mark_readable i) :: !events;
|
||||
if src.check_writable then
|
||||
events := engine#on_writable src.fd (fun _ -> glib_mark_writable i) :: !events
|
||||
done;
|
||||
if timeout = 0. then
|
||||
ignore (Lwt_main.yield ())
|
||||
else if timeout > 0. then
|
||||
events := engine#on_timer timeout false ignore :: !events
|
||||
end
|
||||
|
||||
let leave () =
|
||||
if not !check then begin
|
||||
check := true;
|
||||
List.iter Lwt_engine.stop_event !events;
|
||||
events := [];
|
||||
glib_check ()
|
||||
end
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Installation/removal |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let install ?mode () =
|
||||
match !state with
|
||||
| State_lwt_into_glib _ | State_glib_into_lwt _ ->
|
||||
()
|
||||
| State_none ->
|
||||
let mode =
|
||||
match mode with
|
||||
| Some mode -> mode
|
||||
| None -> if Lwt_sys.windows then `lwt_into_glib else `glib_into_lwt
|
||||
in
|
||||
glib_init ();
|
||||
match mode with
|
||||
| `glib_into_lwt ->
|
||||
state := State_glib_into_lwt(Lwt_sequence.add_l enter Lwt_main.enter_iter_hooks,
|
||||
Lwt_sequence.add_l leave Lwt_main.leave_iter_hooks)
|
||||
| `lwt_into_glib ->
|
||||
let engine = Lwt_engine.get () in
|
||||
Lwt_engine.set ~destroy:false (new engine);
|
||||
state := State_lwt_into_glib engine
|
||||
|
||||
let remove () =
|
||||
match !state with
|
||||
| State_none ->
|
||||
()
|
||||
| State_glib_into_lwt(node_enter, node_leave) ->
|
||||
state := State_none;
|
||||
Lwt_sequence.remove node_enter;
|
||||
Lwt_sequence.remove node_leave;
|
||||
List.iter Lwt_engine.stop_event !events;
|
||||
events := [];
|
||||
glib_stop ()
|
||||
| State_lwt_into_glib engine ->
|
||||
Lwt_engine.set engine
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Misc |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
external iter : bool -> unit = "lwt_glib_iter"
|
||||
external wakeup : unit -> unit = "lwt_glib_wakeup"
|
|
@ -0,0 +1,103 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Interface Lwt_glib
|
||||
* Copyright (C) 2009 Jérémie Dimino
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
(** Glib integration *)
|
||||
|
||||
(** This module allow to use Lwt in GTK applications.
|
||||
|
||||
Here is what you have to do to make Lwt and GTK work together:
|
||||
- call {!install} at the beginning of your program (before or
|
||||
after GMain.init, it does not matter)
|
||||
- do not call GMain.main, write your application as a normal Lwt
|
||||
application instead.
|
||||
|
||||
For example:
|
||||
|
||||
{[
|
||||
let () = Lwt_main.run (
|
||||
(* Initializes GTK. *)
|
||||
ignore (GMain.init ());
|
||||
|
||||
(* Install Lwt<->Glib integration. *)
|
||||
Lwt_glib.install ();
|
||||
|
||||
(* Thread which is wakeup when the main window is closed. *)
|
||||
let waiter, wakener = Lwt.wait () in
|
||||
|
||||
(* Create a window. *)
|
||||
let window = GWindow.window () in
|
||||
|
||||
(* Display something inside the window. *)
|
||||
ignore (GMisc.label ~text:"Hello, world!" ~packing:window#add ());
|
||||
|
||||
(* Quit when the window is closed. *)
|
||||
ignore (window#connect#destroy (Lwt.wakeup wakener));
|
||||
|
||||
(* Show the window. *)
|
||||
window#show ();
|
||||
|
||||
(* Wait for it to be closed. *)
|
||||
waiter
|
||||
)
|
||||
]}
|
||||
*)
|
||||
|
||||
val install : ?mode : [ `glib_into_lwt | `lwt_into_glib ] -> unit -> unit
|
||||
(** Install the Glib<->Lwt integration.
|
||||
|
||||
If [mode] is [`glib_into_lwt] then glib will use the Lwt main
|
||||
loop, and if [mode] is [`lwt_into_glib] then Lwt will use the
|
||||
Glib main loop.
|
||||
|
||||
The first mode is better but for some unknown reason it does not
|
||||
work under Windows, so the second is used as default on Windows
|
||||
while the first one is used as default on Unix.
|
||||
|
||||
If the integration is already active, this function does
|
||||
nothing. *)
|
||||
|
||||
val remove : unit -> unit
|
||||
(** Remove the Glib<->Lwt integration. *)
|
||||
|
||||
val iter : bool -> unit
|
||||
(** This function is not related to Lwt. [iter may_block] does the
|
||||
same as [Glib.Main.iteration may_block] but can safely be called
|
||||
in a multi-threaded program, it will not block the whole
|
||||
program.
|
||||
|
||||
For example:
|
||||
|
||||
{[
|
||||
let main () =
|
||||
while true do
|
||||
Lwt_glib.iter true
|
||||
done
|
||||
|
||||
let thread = Thread.create main ()
|
||||
]}
|
||||
|
||||
Note: you can call this function only from one thread at a time,
|
||||
otherwise it will raise [Failure]. *)
|
||||
|
||||
val wakeup : unit -> unit
|
||||
(** If one thread is blocking on {!iter}, then [wakeup ()] make
|
||||
{!iter} to return immediatly. *)
|
|
@ -0,0 +1,275 @@
|
|||
/* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Module Lwt_glib_stubs
|
||||
* Copyright (C) 2009-2011 Jérémie Dimino
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*/
|
||||
|
||||
#include <caml/mlvalues.h>
|
||||
#include <caml/memory.h>
|
||||
#include <caml/custom.h>
|
||||
#include <caml/alloc.h>
|
||||
#include <caml/fail.h>
|
||||
#include <caml/signals.h>
|
||||
#include <caml/callback.h>
|
||||
#include <glib.h>
|
||||
|
||||
#include "../unix/lwt_unix.h"
|
||||
|
||||
GMainContext *gc;
|
||||
GPollFD *gpollfds = NULL;
|
||||
gint fds_count = 0;
|
||||
gint n_fds;
|
||||
gint max_priority;
|
||||
|
||||
/* +-----------------------------------------------------------------+
|
||||
| Polling |
|
||||
+-----------------------------------------------------------------+ */
|
||||
|
||||
CAMLprim value lwt_glib_poll(value val_fds, value val_count, value val_timeout)
|
||||
{
|
||||
gint timeout, lwt_timeout;
|
||||
long count;
|
||||
int i;
|
||||
GPollFD *gpollfd;
|
||||
gint events, revents;
|
||||
|
||||
CAMLparam3(val_fds, val_count, val_timeout);
|
||||
CAMLlocal5(node, src, node_result, src_result, tmp);
|
||||
|
||||
count = Long_val(val_count);
|
||||
|
||||
g_main_context_dispatch(gc);
|
||||
g_main_context_prepare(gc, &max_priority);
|
||||
|
||||
while (fds_count < count + (n_fds = g_main_context_query(gc, max_priority, &timeout, gpollfds, fds_count))) {
|
||||
free(gpollfds);
|
||||
fds_count = n_fds + count;
|
||||
gpollfds = lwt_unix_malloc(fds_count * sizeof (GPollFD));
|
||||
}
|
||||
|
||||
/* Clear all revents fields. */
|
||||
for (i = 0; i < n_fds + count; i++) gpollfds[i].revents = 0;
|
||||
|
||||
/* Add all Lwt fds. */
|
||||
for (i = n_fds, node = val_fds; i < n_fds + count; i++, node = Field(node, 1)) {
|
||||
src = Field(node, 0);
|
||||
gpollfd = gpollfds + i;
|
||||
#if defined(LWT_ON_WINDOWS)
|
||||
gpollfd->fd = Handle_val(Field(src, 0));
|
||||
#else
|
||||
gpollfd->fd = Int_val(Field(src, 0));
|
||||
#endif
|
||||
events = 0;
|
||||
if (Bool_val(Field(src, 1))) events |= G_IO_IN;
|
||||
if (Bool_val(Field(src, 2))) events |= G_IO_OUT;
|
||||
gpollfd->events = events;
|
||||
}
|
||||
|
||||
lwt_timeout = Int_val(val_timeout);
|
||||
if (timeout < 0 || (lwt_timeout >= 0 && lwt_timeout < timeout))
|
||||
timeout = lwt_timeout;
|
||||
|
||||
/* Do the blocking call. */
|
||||
g_main_context_get_poll_func(gc)(gpollfds, n_fds + count, timeout);
|
||||
g_main_context_check(gc, max_priority, gpollfds, n_fds);
|
||||
|
||||
/* Build the result. */
|
||||
node_result = Val_int(0);
|
||||
for (i = n_fds, node = val_fds; i < n_fds + count; i++, node = Field(node, 1)) {
|
||||
src_result = caml_alloc_tuple(3);
|
||||
src = Field(node, 0);
|
||||
Field(src_result, 0) = Field(src, 0);
|
||||
revents = gpollfds[i].revents;
|
||||
Field(src_result, 1) = Val_bool(revents & G_IO_IN);
|
||||
Field(src_result, 2) = Val_bool(revents & G_IO_OUT);
|
||||
tmp = caml_alloc_tuple(2);
|
||||
Field(tmp, 0) = src_result;
|
||||
Field(tmp, 1) = node_result;
|
||||
node_result = tmp;
|
||||
}
|
||||
|
||||
CAMLreturn(node_result);
|
||||
}
|
||||
|
||||
/* +-----------------------------------------------------------------+
|
||||
| Get sources |
|
||||
+-----------------------------------------------------------------+ */
|
||||
|
||||
#if defined(LWT_ON_WINDOWS)
|
||||
|
||||
static value alloc_fd(HANDLE handle)
|
||||
{
|
||||
value res = win_alloc_handle(handle);
|
||||
int opt;
|
||||
int optlen = sizeof(opt);
|
||||
if (getsockopt((SOCKET)handle, SOL_SOCKET, SO_TYPE, (char *)&opt, &optlen) == 0)
|
||||
Descr_kind_val(res) = KIND_SOCKET;
|
||||
return res;
|
||||
}
|
||||
|
||||
#endif
|
||||
|
||||
CAMLprim value lwt_glib_get_sources()
|
||||
{
|
||||
gint timeout;
|
||||
int i;
|
||||
GPollFD *gpollfd;
|
||||
|
||||
CAMLparam0();
|
||||
CAMLlocal4(fd, fds, src, result);
|
||||
|
||||
g_main_context_dispatch(gc);
|
||||
g_main_context_prepare(gc, &max_priority);
|
||||
|
||||
while (fds_count < (n_fds = g_main_context_query(gc, max_priority, &timeout, gpollfds, fds_count))) {
|
||||
free(gpollfds);
|
||||
fds_count = n_fds;
|
||||
gpollfds = lwt_unix_malloc(fds_count * sizeof (GPollFD));
|
||||
}
|
||||
|
||||
fds = caml_alloc_tuple(n_fds);
|
||||
for (i = 0; i < n_fds; i++) {
|
||||
gpollfd = gpollfds + i;
|
||||
gpollfd->revents = 0;
|
||||
|
||||
#if defined(LWT_ON_WINDOWS)
|
||||
/* On windows, glib file descriptors are handles */
|
||||
fd = alloc_fd((HANDLE)gpollfd->fd);
|
||||
#else
|
||||
fd = Val_int(gpollfd->fd);
|
||||
#endif
|
||||
|
||||
src = caml_alloc_tuple(3);
|
||||
Field(src, 0) = fd;
|
||||
Field(src, 1) = Val_bool(gpollfd->events & G_IO_IN);
|
||||
Field(src, 2) = Val_bool(gpollfd->events & G_IO_OUT);
|
||||
|
||||
Field(fds, i) = src;
|
||||
}
|
||||
|
||||
result = caml_alloc_tuple(2);
|
||||
Store_field(result, 0, fds);
|
||||
Store_field(result, 1, caml_copy_double(timeout * 1e-3));
|
||||
|
||||
CAMLreturn(result);
|
||||
}
|
||||
|
||||
/* +-----------------------------------------------------------------+
|
||||
| Marking |
|
||||
+-----------------------------------------------------------------+ */
|
||||
|
||||
CAMLprim value lwt_glib_mark_readable(value i)
|
||||
{
|
||||
gpollfds[Int_val(i)].revents |= G_IO_IN;
|
||||
return Val_unit;
|
||||
}
|
||||
|
||||
CAMLprim value lwt_glib_mark_writable(value i)
|
||||
{
|
||||
gpollfds[Int_val(i)].revents |= G_IO_OUT;
|
||||
return Val_unit;
|
||||
}
|
||||
|
||||
/* +-----------------------------------------------------------------+
|
||||
| Check |
|
||||
+-----------------------------------------------------------------+ */
|
||||
|
||||
CAMLprim value lwt_glib_check()
|
||||
{
|
||||
g_main_context_check(gc, max_priority, gpollfds, n_fds);
|
||||
return Val_unit;
|
||||
}
|
||||
|
||||
/* +-----------------------------------------------------------------+
|
||||
| Initialization/stopping |
|
||||
+-----------------------------------------------------------------+ */
|
||||
|
||||
CAMLprim value lwt_glib_init()
|
||||
{
|
||||
gc = g_main_context_default();
|
||||
g_main_context_ref(gc);
|
||||
return Val_unit;
|
||||
}
|
||||
|
||||
CAMLprim value lwt_glib_stop()
|
||||
{
|
||||
g_main_context_unref(gc);
|
||||
return Val_unit;
|
||||
}
|
||||
|
||||
/* +-----------------------------------------------------------------+
|
||||
| Misc |
|
||||
+-----------------------------------------------------------------+ */
|
||||
|
||||
CAMLprim value lwt_glib_iter(value may_block)
|
||||
{
|
||||
GMainContext *gc;
|
||||
gint max_priority, timeout;
|
||||
GPollFD *pollfds = NULL;
|
||||
gint pollfds_size = 0;
|
||||
gint nfds;
|
||||
gint i;
|
||||
|
||||
/* Get the main context. */
|
||||
gc = g_main_context_default();
|
||||
|
||||
/* Try to acquire it. */
|
||||
if (!g_main_context_acquire(gc))
|
||||
caml_failwith("Lwt_glib.iter");
|
||||
|
||||
/* Dispatch pending events. */
|
||||
g_main_context_dispatch(gc);
|
||||
|
||||
/* Prepare the context for polling. */
|
||||
g_main_context_prepare(gc, &max_priority);
|
||||
|
||||
/* Get all file descriptors to poll. */
|
||||
while (pollfds_size < (nfds = g_main_context_query(gc, max_priority, &timeout, pollfds, pollfds_size))) {
|
||||
free(pollfds);
|
||||
pollfds_size = nfds;
|
||||
pollfds = lwt_unix_malloc(pollfds_size * sizeof (GPollFD));
|
||||
}
|
||||
|
||||
/* Clear all revents fields. */
|
||||
for (i = 0; i < nfds; i++) pollfds[i].revents = 0;
|
||||
|
||||
/* Set the timeout to 0 if we do not want to block. */
|
||||
if (!Bool_val(may_block)) timeout = 0;
|
||||
|
||||
/* Do the blocking call. */
|
||||
caml_enter_blocking_section();
|
||||
g_main_context_get_poll_func(gc)(pollfds, nfds, timeout);
|
||||
caml_leave_blocking_section();
|
||||
|
||||
/* Let glib parse the result. */
|
||||
g_main_context_check(gc, max_priority, pollfds, nfds);
|
||||
|
||||
/* Release the context. */
|
||||
g_main_context_release(gc);
|
||||
|
||||
free(pollfds);
|
||||
|
||||
return Val_unit;
|
||||
}
|
||||
|
||||
CAMLprim value lwt_glib_wakeup()
|
||||
{
|
||||
g_main_context_wakeup(g_main_context_default());
|
||||
return Val_unit;
|
||||
}
|
|
@ -0,0 +1,4 @@
|
|||
# OASIS_START
|
||||
# DO NOT EDIT (digest: 7a98b43f4d640061bceed7638c0c7efd)
|
||||
Lwt_preemptive
|
||||
# OASIS_STOP
|
|
@ -0,0 +1,195 @@
|
|||
(* Ocsigen
|
||||
* http://www.ocsigen.org
|
||||
* Module lwt_preemptive.ml
|
||||
* Copyright (C) 2005 Nataliya Guts, Vincent Balat, Jérôme Vouillon
|
||||
* Laboratoire PPS - CNRS Université Paris Diderot
|
||||
* 2009 Jérémie Dimino
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later version.
|
||||
* See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful,
|
||||
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
* GNU Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
*)
|
||||
|
||||
let section = Lwt_log.Section.make "lwt(preemptive)"
|
||||
|
||||
open Lwt
|
||||
open Lwt_io
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Parameters |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
(* Minimum number of preemptive threads: *)
|
||||
let min_threads : int ref = ref 0
|
||||
|
||||
(* Maximum number of preemptive threads: *)
|
||||
let max_threads : int ref = ref 0
|
||||
|
||||
(* Size of the waiting queue: *)
|
||||
let max_thread_queued = ref 1000
|
||||
|
||||
let get_max_number_of_threads_queued _ =
|
||||
!max_thread_queued
|
||||
|
||||
let set_max_number_of_threads_queued n =
|
||||
if n < 0 then invalid_arg "Lwt_preemptive.set_max_number_of_threads_queued";
|
||||
max_thread_queued := n
|
||||
|
||||
(* The function for logging errors: *)
|
||||
let error_log = ref (fun msg -> ignore (Lwt_log.error ~section msg))
|
||||
|
||||
(* The total number of preemptive threads currently running: *)
|
||||
let threads_count = ref 0
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Preemptive threads management |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
type thread = {
|
||||
task_channel: (int * (unit -> unit)) Event.channel;
|
||||
(* Channel used to communicate notification id and tasks to the
|
||||
worker thread. *)
|
||||
|
||||
mutable thread : Thread.t;
|
||||
(* The worker thread. *)
|
||||
|
||||
mutable reuse : bool;
|
||||
(* Whether the thread must be readded to the pool when the work is
|
||||
done. *)
|
||||
}
|
||||
|
||||
(* Pool of worker threads: *)
|
||||
let workers : thread Queue.t = Queue.create ()
|
||||
|
||||
(* Queue of clients waiting for a worker to be available: *)
|
||||
let waiters : thread Lwt.u Lwt_sequence.t = Lwt_sequence.create ()
|
||||
|
||||
(* Code executed by a worker: *)
|
||||
let rec worker_loop worker =
|
||||
let id, task = Event.sync (Event.receive worker.task_channel) in
|
||||
task ();
|
||||
(* If there is too much threads, exit. This can happen if the user
|
||||
decreased the maximum: *)
|
||||
if !threads_count > !max_threads then worker.reuse <- false;
|
||||
(* Tell the main thread that work is done: *)
|
||||
Lwt_unix.send_notification id;
|
||||
if worker.reuse then worker_loop worker
|
||||
|
||||
(* create a new worker: *)
|
||||
let make_worker _ =
|
||||
incr threads_count;
|
||||
let worker = {
|
||||
task_channel = Event.new_channel ();
|
||||
thread = Thread.self ();
|
||||
reuse = true;
|
||||
} in
|
||||
worker.thread <- Thread.create worker_loop worker;
|
||||
worker
|
||||
|
||||
(* Add a worker to the pool: *)
|
||||
let add_worker worker =
|
||||
match Lwt_sequence.take_opt_l waiters with
|
||||
| None ->
|
||||
Queue.add worker workers
|
||||
| Some w ->
|
||||
wakeup w worker
|
||||
|
||||
(* Wait for worker to be available, then return it: *)
|
||||
let rec get_worker _ =
|
||||
if not (Queue.is_empty workers) then
|
||||
return (Queue.take workers)
|
||||
else if !threads_count < !max_threads then
|
||||
return (make_worker ())
|
||||
else begin
|
||||
let (res, w) = Lwt.task () in
|
||||
let node = Lwt_sequence.add_r w waiters in
|
||||
Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node);
|
||||
res
|
||||
end
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Initialisation, and dynamic parameters reset |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let get_bounds _ = (!min_threads, !max_threads)
|
||||
|
||||
let set_bounds (min, max) =
|
||||
if min < 0 || max < min then invalid_arg "Lwt_preemptive.set_bounds";
|
||||
let diff = min - !threads_count in
|
||||
min_threads := min;
|
||||
max_threads := max;
|
||||
(* Launch new workers: *)
|
||||
for i = 1 to diff do
|
||||
add_worker (make_worker ())
|
||||
done
|
||||
|
||||
let initialized = ref false
|
||||
|
||||
let init min max errlog =
|
||||
initialized := true;
|
||||
error_log := errlog;
|
||||
set_bounds (min, max)
|
||||
|
||||
let simple_init _ =
|
||||
if not !initialized then begin
|
||||
initialized := true;
|
||||
set_bounds (0, 4)
|
||||
end
|
||||
|
||||
let nbthreads _ = !threads_count
|
||||
let nbthreadsqueued _ = Lwt_sequence.fold_l (fun _ x -> x + 1) waiters 0
|
||||
let nbthreadsbusy _ = !threads_count - Queue.length workers
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Detaching |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let detach f args =
|
||||
simple_init ();
|
||||
let result = ref `Nothing in
|
||||
(* The task for the worker thread: *)
|
||||
let task () =
|
||||
try
|
||||
result := `Success(f args)
|
||||
with exn ->
|
||||
result := `Failure exn
|
||||
in
|
||||
lwt worker = get_worker () in
|
||||
let waiter, wakener = wait () in
|
||||
let id =
|
||||
Lwt_unix.make_notification ~once:true
|
||||
(fun () ->
|
||||
match !result with
|
||||
| `Nothing ->
|
||||
wakeup_exn wakener (Failure "Lwt_preemptive.detach")
|
||||
| `Success value ->
|
||||
wakeup wakener value
|
||||
| `Failure exn ->
|
||||
wakeup_exn wakener exn)
|
||||
in
|
||||
try_lwt
|
||||
(* Send the id and the task to the worker: *)
|
||||
Event.sync (Event.send worker.task_channel (id, task));
|
||||
waiter
|
||||
finally
|
||||
if worker.reuse then
|
||||
(* Put back the worker to the pool: *)
|
||||
add_worker worker
|
||||
else begin
|
||||
decr threads_count;
|
||||
(* Or wait for the thread to terminates, to free its associated
|
||||
resources: *)
|
||||
Thread.join worker.thread
|
||||
end;
|
||||
return ()
|
|
@ -0,0 +1,70 @@
|
|||
(* Ocsigen
|
||||
* http://www.ocsigen.org
|
||||
* Module lwt_preemptive.ml
|
||||
* Copyright (C) 2005 Nataliya Guts, Vincent Balat, Jérôme Vouillon
|
||||
* Laboratoire PPS - CNRS Université Paris Diderot
|
||||
* 2009 Jérémie Dimino
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later version.
|
||||
* See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful,
|
||||
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
* GNU Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
*)
|
||||
|
||||
(** This module allows to mix preemptive threads with [Lwt]
|
||||
cooperative threads. It maintains an extensible pool of preemptive
|
||||
threads to with you can detach computations. *)
|
||||
|
||||
val detach : ('a -> 'b) -> 'a -> 'b Lwt.t
|
||||
(** detaches a computation to a preemptive thread. *)
|
||||
|
||||
val init : int -> int -> (string -> unit) -> unit
|
||||
(** [init min max log] initialises this module. i.e. it launches the
|
||||
minimum number of preemptive threads and starts the {b
|
||||
dispatcher}.
|
||||
|
||||
@param min is the minimum number of threads
|
||||
@param max is the maximum number of threads
|
||||
@param log is used to log error messages
|
||||
|
||||
If {!Lwt_preemptive} has already been initialised, this call
|
||||
only modify bounds and the log function, and return the
|
||||
dispatcher thread. *)
|
||||
|
||||
val simple_init : unit -> unit
|
||||
(** [simple_init ()] does a {i simple initialization}. i.e. with
|
||||
default parameters if the library is not yet initialised.
|
||||
|
||||
Note: this function is automatically called {!detach}. *)
|
||||
|
||||
val get_bounds : unit -> int * int
|
||||
(** [get_bounds ()] returns the minimum and the maximum number of
|
||||
preemptive threads. *)
|
||||
|
||||
val set_bounds : int * int -> unit
|
||||
(** [set_bounds (min, max)] set the minimum and the maximum number
|
||||
of preemptive threads. *)
|
||||
|
||||
val set_max_number_of_threads_queued : int -> unit
|
||||
(** Sets the size of the waiting queue, if no more preemptive
|
||||
threads are available. When the queue is full, {!detach} will
|
||||
sleep until a thread is available. *)
|
||||
|
||||
val get_max_number_of_threads_queued : unit -> int
|
||||
(** Returns the size of the waiting queue, if no more threads are
|
||||
available *)
|
||||
|
||||
(**/**)
|
||||
val nbthreads : unit -> int
|
||||
val nbthreadsbusy : unit -> int
|
||||
val nbthreadsqueued : unit -> int
|
|
@ -0,0 +1,6 @@
|
|||
# OASIS_START
|
||||
# DO NOT EDIT (digest: 8916665f5b5252b5a633514708d91e4b)
|
||||
Lwt_event
|
||||
Lwt_signal
|
||||
Lwt_react
|
||||
# OASIS_STOP
|
|
@ -0,0 +1,54 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Module Lwt_event
|
||||
* Copyright (C) 2009 Jérémie Dimino
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
include Lwt_react.E
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Notifiers |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
type notifier = unit React.event Lwt_sequence.node
|
||||
|
||||
let notifiers = Lwt_sequence.create ()
|
||||
|
||||
let disable n =
|
||||
Lwt_sequence.remove n;
|
||||
React.E.stop (Lwt_sequence.get n)
|
||||
|
||||
let notify f event =
|
||||
Lwt_sequence.add_l (React.E.map f event) notifiers
|
||||
|
||||
let notify_p f event =
|
||||
Lwt_sequence.add_l (React.E.map (fun x -> Lwt.ignore_result (f x)) event) notifiers
|
||||
|
||||
let notify_s f event =
|
||||
let mutex = Lwt_mutex.create () in
|
||||
Lwt_sequence.add_l (React.E.map (fun x -> Lwt.ignore_result (Lwt_mutex.with_lock mutex (fun () -> f x))) event) notifiers
|
||||
|
||||
let always_notify f event =
|
||||
ignore (notify f event)
|
||||
|
||||
let always_notify_p f event =
|
||||
ignore (notify_p f event)
|
||||
|
||||
let always_notify_s f event =
|
||||
ignore (notify_s f event)
|
|
@ -0,0 +1,58 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Interface Lwt_event
|
||||
* Copyright (C) 2009 Jérémie Dimino
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
(** Events utilities *)
|
||||
|
||||
(** This module is deprecated, you should use {!Lwt_react.E}
|
||||
instead. *)
|
||||
|
||||
open React
|
||||
|
||||
val with_finaliser : (unit -> unit) -> 'a event -> 'a event
|
||||
val next : 'a event -> 'a Lwt.t
|
||||
val limit : (unit -> unit Lwt.t) -> 'a event -> 'a event
|
||||
val from : (unit -> 'a Lwt.t) -> 'a event
|
||||
val to_stream : 'a event -> 'a Lwt_stream.t
|
||||
val of_stream : 'a Lwt_stream.t -> 'a event
|
||||
val delay : 'a event Lwt.t -> 'a event
|
||||
val app_s : ('a -> 'b Lwt.t) event -> 'a event -> 'b event
|
||||
val app_p : ('a -> 'b Lwt.t) event -> 'a event -> 'b event
|
||||
val map_s : ('a -> 'b Lwt.t) -> 'a event -> 'b event
|
||||
val map_p: ('a -> 'b Lwt.t) -> 'a event -> 'b event
|
||||
val filter_s : ('a -> bool Lwt.t) -> 'a event -> 'a event
|
||||
val filter_p : ('a -> bool Lwt.t) -> 'a event -> 'a event
|
||||
val fmap_s : ('a -> 'b option Lwt.t) -> 'a event -> 'b event
|
||||
val fmap_p : ('a -> 'b option Lwt.t) -> 'a event -> 'b event
|
||||
val diff_s : ('a -> 'a -> 'b Lwt.t) -> 'a event -> 'b event
|
||||
val accum_s : ('a -> 'a Lwt.t) event -> 'a -> 'a event
|
||||
val fold_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event -> 'a event
|
||||
val merge_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event list -> 'a event
|
||||
val run_s : 'a Lwt.t event -> 'a event
|
||||
val run_p : 'a Lwt.t event -> 'a event
|
||||
type notifier
|
||||
val disable : notifier -> unit
|
||||
val notify : ('a -> unit) -> 'a event -> notifier
|
||||
val notify_p : ('a -> unit Lwt.t) -> 'a event -> notifier
|
||||
val notify_s : ('a -> unit Lwt.t) -> 'a event -> notifier
|
||||
val always_notify : ('a -> unit) -> 'a event -> unit
|
||||
val always_notify_p : ('a -> unit Lwt.t) -> 'a event -> unit
|
||||
val always_notify_s : ('a -> unit Lwt.t) -> 'a event -> unit
|
|
@ -0,0 +1,461 @@
|
|||
(*
|
||||
* lwt_react.ml
|
||||
* ------------
|
||||
* Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
|
||||
* Licence : BSD3
|
||||
*
|
||||
* This file is a part of lwt.
|
||||
*)
|
||||
|
||||
open Lwt
|
||||
|
||||
type 'a event = 'a React.event
|
||||
type 'a signal = 'a React.signal
|
||||
|
||||
module E = struct
|
||||
include React.E
|
||||
|
||||
(* +---------------------------------------------------------------+
|
||||
| Lwt-specific utilities |
|
||||
+---------------------------------------------------------------+ *)
|
||||
|
||||
let finalise f _ = f ()
|
||||
|
||||
let with_finaliser f event =
|
||||
let r = ref () in
|
||||
Gc.finalise (finalise f) r;
|
||||
map (fun x -> ignore r; x) event
|
||||
|
||||
let next ev =
|
||||
let waiter, wakener = Lwt.task () in
|
||||
let ev = map (fun x -> Lwt.wakeup wakener x) (once ev) in
|
||||
Lwt.on_cancel waiter (fun () -> stop ev);
|
||||
waiter
|
||||
|
||||
let limit f e =
|
||||
(* Thread which prevent [e] to occur while it is sleeping *)
|
||||
let limiter = ref (return ()) in
|
||||
|
||||
(* The occurence that is delayed until the limiter returns. *)
|
||||
let delayed = ref None in
|
||||
|
||||
(* The resulting event. *)
|
||||
let event, push = create () in
|
||||
|
||||
let iter =
|
||||
fmap
|
||||
(fun x ->
|
||||
if state !limiter = Sleep then begin
|
||||
(* The limiter is sleeping, we queue the event for later
|
||||
delivering. *)
|
||||
match !delayed with
|
||||
| Some cell ->
|
||||
(* An occurence is alreayd queued, replace it. *)
|
||||
cell := x;
|
||||
None
|
||||
| None ->
|
||||
let cell = ref x in
|
||||
delayed := Some cell;
|
||||
on_success !limiter (fun () -> push !cell);
|
||||
None
|
||||
end else begin
|
||||
(* Set the limiter for future events. *)
|
||||
limiter := f ();
|
||||
(* Send the occurence now. *)
|
||||
push x;
|
||||
None
|
||||
end)
|
||||
e
|
||||
in
|
||||
|
||||
select [iter; event]
|
||||
|
||||
let stop_from wakener () =
|
||||
wakeup wakener None
|
||||
|
||||
let from f =
|
||||
let event, push = create () in
|
||||
let abort_waiter, abort_wakener = Lwt.wait () in
|
||||
let rec loop () =
|
||||
pick [f () >|= (fun x -> Some x); abort_waiter] >>= function
|
||||
| Some v ->
|
||||
push v;
|
||||
loop ()
|
||||
| None ->
|
||||
stop event;
|
||||
return ()
|
||||
in
|
||||
ignore_result (pause () >>= loop);
|
||||
with_finaliser (stop_from abort_wakener) event
|
||||
|
||||
module EQueue :
|
||||
sig
|
||||
type 'a t
|
||||
val create : 'a React.event -> 'a t
|
||||
val pop : 'a t -> 'a option Lwt.t
|
||||
end =
|
||||
struct
|
||||
|
||||
type 'a state =
|
||||
| No_mail
|
||||
| Waiting of 'a option Lwt.u
|
||||
| Full of 'a Queue.t
|
||||
|
||||
type 'a t = {
|
||||
mutable state : 'a state;
|
||||
mutable event : unit React.event;
|
||||
(* field used to prevent garbage collection *)
|
||||
}
|
||||
|
||||
let create event =
|
||||
let box = { state = No_mail; event = never } in
|
||||
let push v =
|
||||
match box.state with
|
||||
| No_mail ->
|
||||
let q = Queue.create () in
|
||||
Queue.push v q;
|
||||
box.state <- Full q
|
||||
| Waiting wakener ->
|
||||
box.state <- No_mail;
|
||||
wakeup_later wakener (Some v)
|
||||
| Full q ->
|
||||
Queue.push v q
|
||||
in
|
||||
box.event <- map push event;
|
||||
box
|
||||
|
||||
let pop b = match b.state with
|
||||
| No_mail ->
|
||||
let waiter, wakener = task () in
|
||||
Lwt.on_cancel waiter (fun () -> b.state <- No_mail);
|
||||
b.state <- Waiting wakener;
|
||||
waiter
|
||||
| Waiting _ ->
|
||||
(* Calls to next are serialized, so this case will never
|
||||
happened *)
|
||||
assert false
|
||||
| Full q ->
|
||||
let v = Queue.take q in
|
||||
if Queue.is_empty q then b.state <- No_mail;
|
||||
return (Some v)
|
||||
end
|
||||
|
||||
let to_stream event =
|
||||
let box = EQueue.create event in
|
||||
Lwt_stream.from (fun () -> EQueue.pop box)
|
||||
|
||||
let stop_stream wakener () =
|
||||
wakeup wakener None
|
||||
|
||||
let of_stream stream =
|
||||
let event, push = create () in
|
||||
let abort_waiter, abort_wakener = Lwt.wait () in
|
||||
let rec loop () =
|
||||
pick [Lwt_stream.get stream; abort_waiter] >>= function
|
||||
| Some value ->
|
||||
push value;
|
||||
loop ()
|
||||
| None ->
|
||||
stop event;
|
||||
return ()
|
||||
in
|
||||
ignore_result (pause () >>= loop);
|
||||
with_finaliser (stop_stream abort_wakener) event
|
||||
|
||||
let delay thread =
|
||||
match poll thread with
|
||||
| Some e ->
|
||||
e
|
||||
| None ->
|
||||
let event, send = create () in
|
||||
on_success thread (fun e -> send e; stop event);
|
||||
switch never event
|
||||
|
||||
let keeped = ref []
|
||||
|
||||
let keep e =
|
||||
keeped := map ignore e :: !keeped
|
||||
|
||||
(* +---------------------------------------------------------------+
|
||||
| Event transofrmations |
|
||||
+---------------------------------------------------------------+ *)
|
||||
|
||||
let run_p e =
|
||||
let event, push = create () in
|
||||
let iter = fmap (fun t -> on_success t push; None) e in
|
||||
select [iter; event]
|
||||
|
||||
let run_s e =
|
||||
let event, push = create () in
|
||||
let mutex = Lwt_mutex.create () in
|
||||
let iter = fmap (fun t -> on_success (Lwt_mutex.with_lock mutex (fun () -> t)) push; None) e in
|
||||
select [iter; event]
|
||||
|
||||
let map_p f e =
|
||||
let event, push = create () in
|
||||
let iter = fmap (fun x -> on_success (f x) push; None) e in
|
||||
select [iter; event]
|
||||
|
||||
let map_s f e =
|
||||
let event, push = create () in
|
||||
let mutex = Lwt_mutex.create () in
|
||||
let iter = fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) e in
|
||||
select [iter; event]
|
||||
|
||||
let app_p ef e =
|
||||
let event, push = create () in
|
||||
let iter = fmap (fun (f, x) -> on_success (f x) push; None) (app (map (fun f x -> (f, x)) ef) e) in
|
||||
select [iter; event]
|
||||
|
||||
let app_s ef e =
|
||||
let event, push = create () in
|
||||
let mutex = Lwt_mutex.create () in
|
||||
let iter = fmap (fun (f, x) -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (app (map (fun f x -> (f, x)) ef) e) in
|
||||
select [iter; event]
|
||||
|
||||
let filter_p f e =
|
||||
let event, push = create () in
|
||||
let iter = fmap (fun x -> on_success (f x) (function true -> push x | false -> ()); None) e in
|
||||
select [iter; event]
|
||||
|
||||
let filter_s f e =
|
||||
let event, push = create () in
|
||||
let mutex = Lwt_mutex.create () in
|
||||
let iter = fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function true -> push x | false -> ()); None) e in
|
||||
select [iter; event]
|
||||
|
||||
let fmap_p f e =
|
||||
let event, push = create () in
|
||||
let iter = fmap (fun x -> on_success (f x) (function Some x -> push x | None -> ()); None) e in
|
||||
select [iter; event]
|
||||
|
||||
let fmap_s f e =
|
||||
let event, push = create () in
|
||||
let mutex = Lwt_mutex.create () in
|
||||
let iter = fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function Some x -> push x | None -> ()); None) e in
|
||||
select [iter; event]
|
||||
|
||||
let diff_s f e =
|
||||
let previous = ref None in
|
||||
let event, push = create () in
|
||||
let mutex = Lwt_mutex.create () in
|
||||
let iter =
|
||||
fmap
|
||||
(fun x ->
|
||||
match !previous with
|
||||
| None ->
|
||||
previous := Some x;
|
||||
None
|
||||
| Some y ->
|
||||
previous := Some x;
|
||||
on_success (Lwt_mutex.with_lock mutex (fun () -> f x y)) push;
|
||||
None)
|
||||
e
|
||||
in
|
||||
select [iter; event]
|
||||
|
||||
let accum_s ef acc =
|
||||
let acc = ref acc in
|
||||
let event, push = create () in
|
||||
let mutex = Lwt_mutex.create () in
|
||||
let iter = fmap (fun f -> on_success (Lwt_mutex.with_lock mutex (fun () -> f !acc)) (fun x -> acc := x; push x); None) ef in
|
||||
select [iter; event]
|
||||
|
||||
let fold_s f acc e =
|
||||
let acc = ref acc in
|
||||
let event, push = create () in
|
||||
let mutex = Lwt_mutex.create () in
|
||||
let iter = fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f !acc x)) (fun x -> acc := x; push x); None) e in
|
||||
select [iter; event]
|
||||
|
||||
let rec rev_fold f acc = function
|
||||
| [] ->
|
||||
return acc
|
||||
| x :: l ->
|
||||
lwt acc = rev_fold f acc l in
|
||||
f acc x
|
||||
|
||||
let merge_s f acc el =
|
||||
let event, push = create () in
|
||||
let mutex = Lwt_mutex.create () in
|
||||
let iter = fmap (fun l -> on_success (Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc l)) push; None) (merge (fun acc x -> x :: acc) [] el) in
|
||||
select [iter; event]
|
||||
end
|
||||
|
||||
module S = struct
|
||||
include React.S
|
||||
|
||||
(* +---------------------------------------------------------------+
|
||||
| Lwt-specific utilities |
|
||||
+---------------------------------------------------------------+ *)
|
||||
|
||||
let finalise f _ = f ()
|
||||
|
||||
let with_finaliser f signal =
|
||||
let r = ref () in
|
||||
Gc.finalise (finalise f) r;
|
||||
map (fun x -> ignore r; x) signal
|
||||
|
||||
let limit ?eq f s =
|
||||
(* Thread which prevent [s] to changes while it is sleeping *)
|
||||
let limiter = ref (f ()) in
|
||||
|
||||
(* The occurence that is delayed until the limiter returns. *)
|
||||
let delayed = ref None in
|
||||
|
||||
(* The resulting event. *)
|
||||
let event, push = E.create () in
|
||||
|
||||
let iter =
|
||||
E.fmap
|
||||
(fun x ->
|
||||
if state !limiter = Sleep then begin
|
||||
(* The limiter is sleeping, we queue the event for later
|
||||
delivering. *)
|
||||
match !delayed with
|
||||
| Some cell ->
|
||||
(* An occurence is alreayd queued, replace it. *)
|
||||
cell := x;
|
||||
None
|
||||
| None ->
|
||||
let cell = ref x in
|
||||
delayed := Some cell;
|
||||
on_success !limiter (fun () -> push !cell);
|
||||
None
|
||||
end else begin
|
||||
(* Set the limiter for future events. *)
|
||||
limiter := f ();
|
||||
(* Send the occurence now. *)
|
||||
push x;
|
||||
None
|
||||
end)
|
||||
(changes s)
|
||||
in
|
||||
|
||||
hold ?eq (value s) (E.select [iter; event])
|
||||
|
||||
let keeped = ref []
|
||||
|
||||
let keep s =
|
||||
keeped := map ignore s :: !keeped
|
||||
|
||||
(* +---------------------------------------------------------------+
|
||||
| Signal transofrmations |
|
||||
+---------------------------------------------------------------+ *)
|
||||
|
||||
let run_s ?eq s =
|
||||
let event, push = E.create () in
|
||||
let mutex = Lwt_mutex.create () in
|
||||
let iter = E.fmap (fun t -> on_success (Lwt_mutex.with_lock mutex (fun () -> t)) push; None) (changes s) in
|
||||
lwt x = Lwt_mutex.with_lock mutex (fun () -> value s) in
|
||||
return (hold ?eq x (E.select [iter; event]))
|
||||
|
||||
let map_s ?eq f s =
|
||||
let event, push = E.create () in
|
||||
let mutex = Lwt_mutex.create () in
|
||||
let iter = E.fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (changes s) in
|
||||
lwt x = Lwt_mutex.with_lock mutex (fun () -> f (value s)) in
|
||||
return (hold ?eq x (E.select [iter; event]))
|
||||
|
||||
let app_s ?eq sf s =
|
||||
let event, push = E.create () in
|
||||
let mutex = Lwt_mutex.create () in
|
||||
let iter = E.fmap (fun (f, x) -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (E.app (E.map (fun f x -> (f, x)) (changes sf)) (changes s)) in
|
||||
lwt x = Lwt_mutex.with_lock mutex (fun () -> (value sf) (value s)) in
|
||||
return (hold ?eq x (E.select [iter; event]))
|
||||
|
||||
let filter_s ?eq f i s =
|
||||
let event, push = E.create () in
|
||||
let mutex = Lwt_mutex.create () in
|
||||
let iter = E.fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function true -> push x | false -> ()); None) (changes s) in
|
||||
let x = value s in
|
||||
Lwt_mutex.with_lock mutex (fun () -> f x) >>= function
|
||||
| true ->
|
||||
return (hold ?eq x (E.select [iter; event]))
|
||||
| false ->
|
||||
return (hold ?eq i (E.select [iter; event]))
|
||||
|
||||
let fmap_s ?eq f i s =
|
||||
let event, push = E.create () in
|
||||
let mutex = Lwt_mutex.create () in
|
||||
let iter = E.fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function Some x -> push x | None -> ()); None) (changes s) in
|
||||
Lwt_mutex.with_lock mutex (fun () -> f (value s)) >>= function
|
||||
| Some x ->
|
||||
return (hold ?eq x (E.select [iter; event]))
|
||||
| None ->
|
||||
return (hold ?eq i (E.select [iter; event]))
|
||||
|
||||
let diff_s f s =
|
||||
let previous = ref (value s) in
|
||||
let event, push = E.create () in
|
||||
let mutex = Lwt_mutex.create () in
|
||||
let iter =
|
||||
E.fmap
|
||||
(fun x ->
|
||||
let y = !previous in
|
||||
previous := x;
|
||||
on_success (Lwt_mutex.with_lock mutex (fun () -> f x y)) push;
|
||||
None)
|
||||
(changes s)
|
||||
in
|
||||
E.select [iter; event]
|
||||
|
||||
let sample_s f e s =
|
||||
E.map_s (fun x -> f x (value s)) e
|
||||
|
||||
let accum_s ?eq ef i =
|
||||
hold ?eq i (E.accum_s ef i)
|
||||
|
||||
let fold_s ?eq f i e =
|
||||
hold ?eq i (E.fold_s f i e)
|
||||
|
||||
let rec rev_fold f acc = function
|
||||
| [] ->
|
||||
return acc
|
||||
| x :: l ->
|
||||
lwt acc = rev_fold f acc l in
|
||||
f acc x
|
||||
|
||||
let merge_s ?eq f acc sl =
|
||||
let s = merge (fun acc x -> x :: acc) [] sl in
|
||||
let event, push = E.create () in
|
||||
let mutex = Lwt_mutex.create () in
|
||||
let iter = E.fmap (fun l -> on_success (Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc l)) push; None) (changes s) in
|
||||
lwt x = Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc (value s)) in
|
||||
return (hold ?eq x (E.select [iter; event]))
|
||||
|
||||
let l1_s ?eq f s1 =
|
||||
map_s ?eq f s1
|
||||
|
||||
let l2_s ?eq f s1 s2 =
|
||||
map_s ?eq (fun (x1, x2) -> f x1 x2) (l2 (fun x1 x2 -> (x1, x2)) s1 s2)
|
||||
|
||||
let l3_s ?eq f s1 s2 s3 =
|
||||
map_s ?eq (fun (x1, x2, x3) -> f x1 x2 x3) (l3 (fun x1 x2 x3-> (x1, x2, x3)) s1 s2 s3)
|
||||
|
||||
let l4_s ?eq f s1 s2 s3 s4 =
|
||||
map_s ?eq (fun (x1, x2, x3, x4) -> f x1 x2 x3 x4) (l4 (fun x1 x2 x3 x4-> (x1, x2, x3, x4)) s1 s2 s3 s4)
|
||||
|
||||
let l5_s ?eq f s1 s2 s3 s4 s5 =
|
||||
map_s ?eq (fun (x1, x2, x3, x4, x5) -> f x1 x2 x3 x4 x5) (l5 (fun x1 x2 x3 x4 x5-> (x1, x2, x3, x4, x5)) s1 s2 s3 s4 s5)
|
||||
|
||||
let l6_s ?eq f s1 s2 s3 s4 s5 s6 =
|
||||
map_s ?eq (fun (x1, x2, x3, x4, x5, x6) -> f x1 x2 x3 x4 x5 x6) (l6 (fun x1 x2 x3 x4 x5 x6-> (x1, x2, x3, x4, x5, x6)) s1 s2 s3 s4 s5 s6)
|
||||
|
||||
(* +---------------------------------------------------------------+
|
||||
| Monadic interface |
|
||||
+---------------------------------------------------------------+ *)
|
||||
|
||||
let return =
|
||||
const
|
||||
|
||||
let bind ?eq s f =
|
||||
switch ?eq (f (value s)) (E.map f (changes s))
|
||||
|
||||
let bind_s ?eq s f =
|
||||
let event, push = E.create () in
|
||||
let mutex = Lwt_mutex.create () in
|
||||
let iter = E.fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (changes s) in
|
||||
lwt x = Lwt_mutex.with_lock mutex (fun () -> f (value s)) in
|
||||
Lwt.return (switch ?eq x (E.select [iter; event]))
|
||||
end
|
|
@ -0,0 +1,166 @@
|
|||
(*
|
||||
* lwt_react.mli
|
||||
* -------------
|
||||
* Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
|
||||
* Licence : BSD3
|
||||
*
|
||||
* This file is a part of lwt.
|
||||
*)
|
||||
|
||||
(** React utilities *)
|
||||
|
||||
(** This module is a replacement for the React module. You can open it
|
||||
instead of the React module in order to get all react's functions
|
||||
plus Lwt ones. *)
|
||||
|
||||
type 'a event = 'a React.event
|
||||
(** Type of events. *)
|
||||
|
||||
type 'a signal = 'a React.signal
|
||||
(** Type of signals. *)
|
||||
|
||||
module E : sig
|
||||
include module type of React.E
|
||||
|
||||
(** {6 Lwt-specific utilities} *)
|
||||
|
||||
val with_finaliser : (unit -> unit) -> 'a event -> 'a event
|
||||
(** [with_finaliser f e] returns an event [e'] which behave as
|
||||
[e], except that [f] is called when [e'] is garbage
|
||||
collected. *)
|
||||
|
||||
val next : 'a event -> 'a Lwt.t
|
||||
(** [next e] returns the next occurrence of [e] *)
|
||||
|
||||
val limit : (unit -> unit Lwt.t) -> 'a event -> 'a event
|
||||
(** [limit f e] limits the rate of [e] with [f].
|
||||
|
||||
For example, to limit the rate of an event to 1 per second you
|
||||
can use: [limit (fun () -> Lwt_unix.sleep 1.0) event]. *)
|
||||
|
||||
val from : (unit -> 'a Lwt.t) -> 'a event
|
||||
(** [from f] creates an event which occurs each [f ()] returns a
|
||||
value. If [f] raises an exception, the event is just
|
||||
stopped. *)
|
||||
|
||||
val to_stream : 'a event -> 'a Lwt_stream.t
|
||||
(** Creates a stream holding all values occurring on the given
|
||||
event *)
|
||||
|
||||
val of_stream : 'a Lwt_stream.t -> 'a event
|
||||
(** [of_stream stream] creates an event which occurs each time a
|
||||
value is available on the stream. *)
|
||||
|
||||
val delay : 'a event Lwt.t -> 'a event
|
||||
(** [delay thread] is an event which does not occurs until
|
||||
[thread] returns. Then it behaves as the event returned by
|
||||
[thread]. *)
|
||||
|
||||
val keep : 'a event -> unit
|
||||
(** [keep e] keeps a reference to [e] so it will never be garbage
|
||||
collected. *)
|
||||
|
||||
(** {6 Threaded versions of React transformation functions} *)
|
||||
|
||||
(** The following functions behave as their [React] counterpart,
|
||||
except that they takes functions that may yield.
|
||||
|
||||
As usual the [_s] suffix is used when calls are serialized, and
|
||||
the [_p] suffix is used when they are not.
|
||||
|
||||
Note that [*_p] functions may not preserve event order. *)
|
||||
|
||||
val app_s : ('a -> 'b Lwt.t) event -> 'a event -> 'b event
|
||||
val app_p : ('a -> 'b Lwt.t) event -> 'a event -> 'b event
|
||||
|
||||
val map_s : ('a -> 'b Lwt.t) -> 'a event -> 'b event
|
||||
val map_p: ('a -> 'b Lwt.t) -> 'a event -> 'b event
|
||||
|
||||
val filter_s : ('a -> bool Lwt.t) -> 'a event -> 'a event
|
||||
val filter_p : ('a -> bool Lwt.t) -> 'a event -> 'a event
|
||||
|
||||
val fmap_s : ('a -> 'b option Lwt.t) -> 'a event -> 'b event
|
||||
val fmap_p : ('a -> 'b option Lwt.t) -> 'a event -> 'b event
|
||||
|
||||
val diff_s : ('a -> 'a -> 'b Lwt.t) -> 'a event -> 'b event
|
||||
|
||||
val accum_s : ('a -> 'a Lwt.t) event -> 'a -> 'a event
|
||||
|
||||
val fold_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event -> 'a event
|
||||
|
||||
val merge_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event list -> 'a event
|
||||
|
||||
val run_s : 'a Lwt.t event -> 'a event
|
||||
val run_p : 'a Lwt.t event -> 'a event
|
||||
end
|
||||
|
||||
module S : sig
|
||||
include module type of React.S
|
||||
|
||||
(** {6 Monadic interface} *)
|
||||
|
||||
val return : 'a -> 'a signal
|
||||
(** Same as [const]. *)
|
||||
|
||||
val bind : ?eq : ('b -> 'b -> bool) -> 'a signal -> ('a -> 'b signal) -> 'b signal
|
||||
(** [bind ?eq s f] is initially [f x] where [x] is the current
|
||||
value of [s]. Each time [s] changes to a new value [y], [bind
|
||||
signal f] is set to [f y], until the next change of
|
||||
[signal]. *)
|
||||
|
||||
val bind_s : ?eq : ('b -> 'b -> bool) -> 'a signal -> ('a -> 'b signal Lwt.t) -> 'b signal Lwt.t
|
||||
(** Same as {!bind} except that [f] returns a thread. Calls to [f]
|
||||
are serialized. *)
|
||||
|
||||
(** {6 Lwt-specific utilities} *)
|
||||
|
||||
val with_finaliser : (unit -> unit) -> 'a signal -> 'a signal
|
||||
(** [with_finaliser f s] returns a signal [s'] which behave as
|
||||
[s], except that [f] is called when [s'] is garbage
|
||||
collected. *)
|
||||
|
||||
val limit : ?eq : ('a -> 'a -> bool) -> (unit -> unit Lwt.t) -> 'a signal -> 'a signal
|
||||
(** [limit f s] limits the rate of [s] update with [f].
|
||||
|
||||
For example, to limit it to 1 per second, you can use: [limit
|
||||
(fun () -> Lwt_unix.sleep 1.0) s]. *)
|
||||
|
||||
val keep : 'a signal -> unit
|
||||
(** [keep s] keeps a reference to [s] so it will never be garbage
|
||||
collected. *)
|
||||
|
||||
(** {6 Threaded versions of React transformation functions} *)
|
||||
|
||||
(** The following functions behave as their [React] counterpart,
|
||||
except that they takes functions that may yield.
|
||||
|
||||
The [_s] suffix means that calls are serialized.
|
||||
*)
|
||||
|
||||
val app_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) signal -> 'a signal -> 'b signal Lwt.t
|
||||
|
||||
val map_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) -> 'a signal -> 'b signal Lwt.t
|
||||
|
||||
val filter_s : ?eq : ('a -> 'a -> bool) -> ('a -> bool Lwt.t) -> 'a -> 'a signal -> 'a signal Lwt.t
|
||||
|
||||
val fmap_s : ?eq:('b -> 'b -> bool) -> ('a -> 'b option Lwt.t) -> 'b -> 'a signal -> 'b signal Lwt.t
|
||||
|
||||
val diff_s : ('a -> 'a -> 'b Lwt.t) -> 'a signal -> 'b event
|
||||
|
||||
val sample_s : ('b -> 'a -> 'c Lwt.t) -> 'b event -> 'a signal -> 'c event
|
||||
|
||||
val accum_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'a Lwt.t) event -> 'a -> 'a signal
|
||||
|
||||
val fold_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event -> 'a signal
|
||||
|
||||
val merge_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b signal list -> 'a signal Lwt.t
|
||||
|
||||
val l1_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) -> 'a signal -> 'b signal Lwt.t
|
||||
val l2_s : ?eq : ('c -> 'c -> bool) -> ('a -> 'b -> 'c Lwt.t) -> 'a signal -> 'b signal -> 'c signal Lwt.t
|
||||
val l3_s : ?eq : ('d -> 'd -> bool) -> ('a -> 'b -> 'c -> 'd Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal Lwt.t
|
||||
val l4_s : ?eq : ('e -> 'e -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal Lwt.t
|
||||
val l5_s : ?eq : ('f -> 'f -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> 'f signal Lwt.t
|
||||
val l6_s : ?eq : ('g -> 'g -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> 'f signal -> 'g signal Lwt.t
|
||||
|
||||
val run_s : ?eq : ('a -> 'a -> bool) -> 'a Lwt.t signal -> 'a signal Lwt.t
|
||||
end
|
|
@ -0,0 +1,175 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Module Lwt_signal
|
||||
* Copyright (C) 2009 Jérémie Dimino
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
include Lwt_react.S
|
||||
|
||||
open Lwt_react
|
||||
open Lwt
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Notifiers |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
type notifier = unit React.signal Lwt_sequence.node
|
||||
|
||||
let notifiers = Lwt_sequence.create ()
|
||||
|
||||
let disable n =
|
||||
Lwt_sequence.remove n;
|
||||
stop (Lwt_sequence.get n)
|
||||
|
||||
let notify f signal =
|
||||
Lwt_sequence.add_l (S.map f signal) notifiers
|
||||
|
||||
let notify_p f signal =
|
||||
Lwt_sequence.add_l (S.map (fun x -> Lwt.ignore_result (f x)) signal) notifiers
|
||||
|
||||
let notify_s f signal =
|
||||
let mutex = Lwt_mutex.create () in
|
||||
Lwt_sequence.add_l (S.map (fun x -> Lwt.ignore_result (Lwt_mutex.with_lock mutex (fun () -> f x))) signal) notifiers
|
||||
|
||||
let always_notify f signal =
|
||||
ignore (notify f signal)
|
||||
|
||||
let always_notify_p f signal =
|
||||
ignore (notify_p f signal)
|
||||
|
||||
let always_notify_s f signal =
|
||||
ignore (notify_s f signal)
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Lwt-specific utilities |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let delay thread =
|
||||
match poll thread with
|
||||
| Some signal ->
|
||||
let event1, send1 = React.E.create () in
|
||||
let event2, send2 = React.E.create () in
|
||||
ignore (
|
||||
(* If the thread has already terminated, we make a pause to
|
||||
prevent the first occurence to be lost *)
|
||||
lwt () = pause () in
|
||||
send1 (value signal);
|
||||
send2 (changes signal);
|
||||
React.E.stop event1;
|
||||
React.E.stop event2;
|
||||
return ()
|
||||
);
|
||||
React.E.switch event1 event2
|
||||
| None ->
|
||||
let event1, send1 = React.E.create () in
|
||||
let event2, send2 = React.E.create () in
|
||||
ignore (
|
||||
lwt signal = thread in
|
||||
send1 (value signal);
|
||||
send2 (changes signal);
|
||||
React.E.stop event1;
|
||||
React.E.stop event2;
|
||||
return ()
|
||||
);
|
||||
React.E.switch event1 event2
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Signal transofrmations |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let run_s ?eq i s =
|
||||
let event, push = E.create () in
|
||||
let mutex = Lwt_mutex.create () in
|
||||
let iter = E.fmap (fun t -> on_success (Lwt_mutex.with_lock mutex (fun () -> t)) push; None) (changes s) in
|
||||
on_success (Lwt_mutex.with_lock mutex (fun () -> value s)) push;
|
||||
hold ?eq i (E.select [iter; event])
|
||||
|
||||
let map_s ?eq f i s =
|
||||
let event, push = E.create () in
|
||||
let mutex = Lwt_mutex.create () in
|
||||
let iter = E.fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (changes s) in
|
||||
on_success (Lwt_mutex.with_lock mutex (fun () -> f (value s))) push;
|
||||
hold ?eq i (E.select [iter; event])
|
||||
|
||||
let app_s ?eq sf i s =
|
||||
let event, push = E.create () in
|
||||
let mutex = Lwt_mutex.create () in
|
||||
let iter = E.fmap (fun (f, x) -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (E.app (E.map (fun f x -> (f, x)) (changes sf)) (changes s)) in
|
||||
on_success (Lwt_mutex.with_lock mutex (fun () -> (value sf) (value s))) push;
|
||||
hold ?eq i (E.select [iter; event])
|
||||
|
||||
let filter_s ?eq f i s =
|
||||
let event, push = E.create () in
|
||||
let mutex = Lwt_mutex.create () in
|
||||
let iter = E.fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function true -> push x | false -> ()); None) (changes s) in
|
||||
let x = value s in
|
||||
on_success
|
||||
(Lwt_mutex.with_lock mutex (fun () -> f x))
|
||||
(function
|
||||
| true ->
|
||||
push x
|
||||
| false ->
|
||||
());
|
||||
hold ?eq i (E.select [iter; event])
|
||||
|
||||
let fmap_s ?eq f i s =
|
||||
let event, push = E.create () in
|
||||
let mutex = Lwt_mutex.create () in
|
||||
let iter = E.fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function Some x -> push x | None -> ()); None) (changes s) in
|
||||
on_success
|
||||
(Lwt_mutex.with_lock mutex (fun () -> f (value s)))
|
||||
(function
|
||||
| Some x ->
|
||||
push x
|
||||
| None ->
|
||||
());
|
||||
hold ?eq i (E.select [iter; event])
|
||||
|
||||
let rec rev_fold f acc = function
|
||||
| [] ->
|
||||
return acc
|
||||
| x :: l ->
|
||||
lwt acc = rev_fold f acc l in
|
||||
f acc x
|
||||
|
||||
let merge_s ?eq f acc sl =
|
||||
let s = merge (fun acc x -> x :: acc) [] sl in
|
||||
let event, push = E.create () in
|
||||
let mutex = Lwt_mutex.create () in
|
||||
let iter = E.fmap (fun l -> on_success (Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc l)) push; None) (changes s) in
|
||||
on_success (Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc (value s))) push;
|
||||
hold ?eq acc (E.select [iter; event])
|
||||
|
||||
let l1_s ?eq f i s1 =
|
||||
map_s ?eq f i s1
|
||||
|
||||
let l2_s ?eq f i s1 s2 =
|
||||
map_s ?eq (fun (x1, x2) -> f x1 x2) i (l2 (fun x1 x2 -> (x1, x2)) s1 s2)
|
||||
|
||||
let l3_s ?eq f i s1 s2 s3 =
|
||||
map_s ?eq (fun (x1, x2, x3) -> f x1 x2 x3) i (l3 (fun x1 x2 x3-> (x1, x2, x3)) s1 s2 s3)
|
||||
|
||||
let l4_s ?eq f i s1 s2 s3 s4 =
|
||||
map_s ?eq (fun (x1, x2, x3, x4) -> f x1 x2 x3 x4) i (l4 (fun x1 x2 x3 x4-> (x1, x2, x3, x4)) s1 s2 s3 s4)
|
||||
|
||||
let l5_s ?eq f i s1 s2 s3 s4 s5 =
|
||||
map_s ?eq (fun (x1, x2, x3, x4, x5) -> f x1 x2 x3 x4 x5) i (l5 (fun x1 x2 x3 x4 x5-> (x1, x2, x3, x4, x5)) s1 s2 s3 s4 s5)
|
||||
|
||||
let l6_s ?eq f i s1 s2 s3 s4 s5 s6 =
|
||||
map_s ?eq (fun (x1, x2, x3, x4, x5, x6) -> f x1 x2 x3 x4 x5 x6) i (l6 (fun x1 x2 x3 x4 x5 x6-> (x1, x2, x3, x4, x5, x6)) s1 s2 s3 s4 s5 s6)
|
|
@ -0,0 +1,57 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Interface Lwt_event
|
||||
* Copyright (C) 2009 Jérémie Dimino
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
(** Signals utilities *)
|
||||
|
||||
(** This module is deprecated, you should use {!Lwt_react.S}
|
||||
instead. *)
|
||||
|
||||
open React
|
||||
val return : 'a -> 'a signal
|
||||
val bind : ?eq : ('b -> 'b -> bool) -> 'a signal -> ('a -> 'b signal) -> 'b signal
|
||||
val with_finaliser : (unit -> unit) -> 'a signal -> 'a signal
|
||||
val limit : ?eq : ('a -> 'a -> bool) -> (unit -> unit Lwt.t) -> 'a signal -> 'a signal
|
||||
val delay : 'a signal Lwt.t -> 'a event
|
||||
val app_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) signal -> 'b -> 'a signal -> 'b signal
|
||||
val map_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) -> 'b -> 'a signal -> 'b signal
|
||||
val filter_s : ?eq : ('a -> 'a -> bool) -> ('a -> bool Lwt.t) -> 'a -> 'a signal -> 'a signal
|
||||
val fmap_s : ?eq:('b -> 'b -> bool) -> ('a -> 'b option Lwt.t) -> 'b -> 'a signal -> 'b signal
|
||||
val diff_s : ('a -> 'a -> 'b Lwt.t) -> 'a signal -> 'b event
|
||||
val sample_s : ('b -> 'a -> 'c Lwt.t) -> 'b event -> 'a signal -> 'c event
|
||||
val accum_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'a Lwt.t) event -> 'a -> 'a signal
|
||||
val fold_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event -> 'a signal
|
||||
val merge_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b signal list -> 'a signal
|
||||
val l1_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) -> 'b -> ('a signal -> 'b signal)
|
||||
val l2_s : ?eq : ('c -> 'c -> bool) -> ('a -> 'b -> 'c Lwt.t) -> 'c -> ('a signal -> 'b signal -> 'c signal)
|
||||
val l3_s : ?eq : ('d -> 'd -> bool) -> ('a -> 'b -> 'c -> 'd Lwt.t) -> 'd -> ('a signal -> 'b signal -> 'c signal -> 'd signal)
|
||||
val l4_s : ?eq : ('e -> 'e -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e Lwt.t) -> 'e -> ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal)
|
||||
val l5_s : ?eq : ('f -> 'f -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f Lwt.t) -> 'f -> ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> 'f signal)
|
||||
val l6_s : ?eq : ('g -> 'g -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g Lwt.t) -> 'g -> ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> 'f signal -> 'g signal)
|
||||
val run_s : ?eq : ('a -> 'a -> bool) -> 'a -> 'a Lwt.t signal -> 'a signal
|
||||
type notifier
|
||||
val disable : notifier -> unit
|
||||
val notify : ('a -> unit) -> 'a signal -> notifier
|
||||
val notify_p : ('a -> unit Lwt.t) -> 'a signal -> notifier
|
||||
val notify_s : ('a -> unit Lwt.t) -> 'a signal -> notifier
|
||||
val always_notify : ('a -> unit) -> 'a signal -> unit
|
||||
val always_notify_p : ('a -> unit Lwt.t) -> 'a signal -> unit
|
||||
val always_notify_s : ('a -> unit Lwt.t) -> 'a signal -> unit
|
|
@ -0,0 +1,4 @@
|
|||
# OASIS_START
|
||||
# DO NOT EDIT (digest: de6ce24e129acca71e8908d2344cd786)
|
||||
Lwt_simple_top
|
||||
# OASIS_STOP
|
|
@ -0,0 +1,47 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Module Lwt_simple_top
|
||||
* Copyright (C) 2009 Jérémie Dimino
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
(* Integration with the toplevel for people who do not have the
|
||||
enhanced toplevel (package lwt.top, which require ocaml-text). *)
|
||||
|
||||
open Lwt
|
||||
open Lwt_io
|
||||
|
||||
let read_input_non_interactive prompt buffer len =
|
||||
let rec loop i =
|
||||
if i = len then
|
||||
return (i, false)
|
||||
else
|
||||
read_char_opt stdin >>= function
|
||||
| Some c ->
|
||||
buffer.[i] <- c;
|
||||
if c = '\n' then
|
||||
return (i + 1, false)
|
||||
else
|
||||
loop (i + 1)
|
||||
| None ->
|
||||
return (i, true)
|
||||
in
|
||||
Lwt_main.run (write stdout prompt >> loop 0)
|
||||
|
||||
let _ =
|
||||
Toploop.read_interactive_input := read_input_non_interactive
|
|
@ -0,0 +1,4 @@
|
|||
# OASIS_START
|
||||
# DO NOT EDIT (digest: ab07ef30d9c1dd9dd2a1f2eef22e9d68)
|
||||
Lwt_ssl
|
||||
# OASIS_STOP
|
|
@ -0,0 +1,175 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Module Lwt_ssl
|
||||
* Copyright (C) 2005-2008 Jérôme Vouillon
|
||||
* Laboratoire PPS - CNRS Université Paris Diderot
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
type t =
|
||||
Plain
|
||||
| SSL of Ssl.socket
|
||||
|
||||
type socket = Lwt_unix.file_descr * t
|
||||
|
||||
let is_ssl s =
|
||||
match snd s with
|
||||
Plain -> false
|
||||
| _ -> true
|
||||
|
||||
let wrap_call f () =
|
||||
try
|
||||
f ()
|
||||
with
|
||||
(Ssl.Connection_error err | Ssl.Accept_error err |
|
||||
Ssl.Read_error err | Ssl.Write_error err) as e ->
|
||||
match err with
|
||||
Ssl.Error_want_read ->
|
||||
raise Lwt_unix.Retry_read
|
||||
| Ssl.Error_want_write ->
|
||||
raise Lwt_unix.Retry_write
|
||||
| _ ->
|
||||
raise e
|
||||
|
||||
let repeat_call fd f =
|
||||
try
|
||||
Lwt_unix.check_descriptor fd;
|
||||
Lwt.return (wrap_call f ())
|
||||
with
|
||||
Lwt_unix.Retry_read ->
|
||||
Lwt_unix.register_action Lwt_unix.Read fd (wrap_call f)
|
||||
| Lwt_unix.Retry_write ->
|
||||
Lwt_unix.register_action Lwt_unix.Write fd (wrap_call f)
|
||||
| e ->
|
||||
raise_lwt e
|
||||
|
||||
(****)
|
||||
|
||||
let plain fd = (fd, Plain)
|
||||
|
||||
let embed_socket fd context = (fd, SSL(Ssl.embed_socket (Lwt_unix.unix_file_descr fd) context))
|
||||
|
||||
let ssl_accept fd ctx =
|
||||
let socket = Ssl.embed_socket (Lwt_unix.unix_file_descr fd) ctx in
|
||||
Lwt.bind
|
||||
(repeat_call fd (fun () -> Ssl.accept socket)) (fun () ->
|
||||
Lwt.return (fd, SSL socket))
|
||||
|
||||
let ssl_connect fd ctx =
|
||||
let socket = Ssl.embed_socket (Lwt_unix.unix_file_descr fd) ctx in
|
||||
Lwt.bind
|
||||
(repeat_call fd (fun () -> Ssl.connect socket)) (fun () ->
|
||||
Lwt.return (fd, SSL socket))
|
||||
|
||||
let read (fd, s) buf pos len =
|
||||
match s with
|
||||
| Plain ->
|
||||
Lwt_unix.read fd buf pos len
|
||||
| SSL s ->
|
||||
if len = 0 then
|
||||
Lwt.return 0
|
||||
else
|
||||
repeat_call fd
|
||||
(fun () ->
|
||||
try
|
||||
Ssl.read s buf pos len
|
||||
with Ssl.Read_error Ssl.Error_zero_return ->
|
||||
0)
|
||||
|
||||
let read_bytes (fd, s) buf pos len =
|
||||
match s with
|
||||
| Plain ->
|
||||
Lwt_bytes.read fd buf pos len
|
||||
| SSL s ->
|
||||
if len = 0 then
|
||||
Lwt.return 0
|
||||
else
|
||||
repeat_call fd
|
||||
(fun () ->
|
||||
try
|
||||
let str = String.create len in
|
||||
let n = Ssl.read s str 0 len in
|
||||
Lwt_bytes.blit_string_bytes str 0 buf pos len;
|
||||
n
|
||||
with Ssl.Read_error Ssl.Error_zero_return ->
|
||||
0)
|
||||
|
||||
let write (fd, s) buf pos len =
|
||||
match s with
|
||||
| Plain ->
|
||||
Lwt_unix.write fd buf pos len
|
||||
| SSL s ->
|
||||
if len = 0 then
|
||||
Lwt.return 0
|
||||
else
|
||||
repeat_call fd
|
||||
(fun () ->
|
||||
Ssl.write s buf pos len)
|
||||
|
||||
let write_bytes (fd, s) buf pos len =
|
||||
match s with
|
||||
| Plain ->
|
||||
Lwt_bytes.write fd buf pos len
|
||||
| SSL s ->
|
||||
if len = 0 then
|
||||
Lwt.return 0
|
||||
else
|
||||
repeat_call fd
|
||||
(fun () ->
|
||||
let str = String.create len in
|
||||
Lwt_bytes.blit_bytes_string buf pos str 0 len;
|
||||
Ssl.write s str 0 len)
|
||||
|
||||
let wait_read (fd, s) =
|
||||
match s with
|
||||
Plain -> Lwt_unix.wait_read fd
|
||||
| SSL _ -> Lwt_unix.yield ()
|
||||
|
||||
let wait_write (fd, s) =
|
||||
match s with
|
||||
Plain -> Lwt_unix.wait_write fd
|
||||
| SSL _ -> Lwt_unix.yield ()
|
||||
|
||||
let out_channel_of_descr s =
|
||||
Lwt_io.make ~mode:Lwt_io.output (fun buf pos len -> write_bytes s buf pos len)
|
||||
|
||||
let in_channel_of_descr s =
|
||||
Lwt_io.make ~mode:Lwt_io.input (fun buf pos len -> read_bytes s buf pos len)
|
||||
|
||||
let ssl_shutdown (fd, s) =
|
||||
match s with
|
||||
Plain -> Lwt.return ()
|
||||
| SSL s -> repeat_call fd (fun () -> Ssl.shutdown s)
|
||||
|
||||
let shutdown (fd, _) cmd = Lwt_unix.shutdown fd cmd
|
||||
|
||||
let close (fd, _) = Lwt_unix.close fd
|
||||
|
||||
let abort (fd, _) = Lwt_unix.abort fd
|
||||
|
||||
let get_fd (fd,socket) =
|
||||
match socket with
|
||||
| Plain -> Lwt_unix.unix_file_descr fd
|
||||
| SSL socket -> (Ssl.file_descr_of_socket socket)
|
||||
|
||||
let getsockname s =
|
||||
Unix.getsockname (get_fd s)
|
||||
|
||||
let getpeername s =
|
||||
Unix.getpeername (get_fd s)
|
||||
|
|
@ -0,0 +1,58 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Interface Lwt_ssl
|
||||
* Copyright (C) 2005-2008 Jérôme Vouillon
|
||||
* Laboratoire PPS - CNRS Université Paris Diderot
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
(** OCaml-SSL integration *)
|
||||
|
||||
type socket
|
||||
|
||||
val ssl_accept : Lwt_unix.file_descr -> Ssl.context -> socket Lwt.t
|
||||
val ssl_connect : Lwt_unix.file_descr -> Ssl.context -> socket Lwt.t
|
||||
val plain : Lwt_unix.file_descr -> socket
|
||||
val embed_socket : Lwt_unix.file_descr -> Ssl.context -> socket
|
||||
|
||||
val read : socket -> string -> int -> int -> int Lwt.t
|
||||
val write : socket -> string -> int -> int -> int Lwt.t
|
||||
|
||||
val read_bytes : socket -> Lwt_bytes.t -> int -> int -> int Lwt.t
|
||||
val write_bytes : socket -> Lwt_bytes.t -> int -> int -> int Lwt.t
|
||||
|
||||
(* Really wait on a plain socket, just yield over SSL *)
|
||||
val wait_read : socket -> unit Lwt.t
|
||||
val wait_write : socket -> unit Lwt.t
|
||||
|
||||
val shutdown : socket -> Unix.shutdown_command -> unit
|
||||
val close : socket -> unit Lwt.t
|
||||
|
||||
val out_channel_of_descr : socket -> Lwt_chan.out_channel
|
||||
val in_channel_of_descr : socket -> Lwt_chan.in_channel
|
||||
|
||||
val ssl_shutdown : socket -> unit Lwt.t
|
||||
|
||||
val abort : socket -> exn -> unit
|
||||
|
||||
(** Are we using an SSL socket? *)
|
||||
val is_ssl : socket -> bool
|
||||
|
||||
val getsockname : socket -> Unix.sockaddr
|
||||
|
||||
val getpeername : socket -> Unix.sockaddr
|
|
@ -0,0 +1,4 @@
|
|||
# OASIS_START
|
||||
# DO NOT EDIT (digest: 49d58712acb378a903b0dfd06803031a)
|
||||
lwt_text_stubs.o
|
||||
# OASIS_STOP
|
|
@ -0,0 +1,6 @@
|
|||
# OASIS_START
|
||||
# DO NOT EDIT (digest: 445f786e72bdc58b36891d69973effc4)
|
||||
Lwt_text
|
||||
Lwt_term
|
||||
Lwt_read_line
|
||||
# OASIS_STOP
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,453 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Module Lwt_read_line
|
||||
* Copyright (C) 2009 Jérémie Dimino
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
(** Interactive line input *)
|
||||
|
||||
(** {6 Definitions} *)
|
||||
|
||||
exception Interrupt
|
||||
(** Exception raised when the user press [Ctrl^D] *)
|
||||
|
||||
type edition_state = Text.t * Text.t
|
||||
(** An edition state, it is a pair of two UTF-8 encoded strings:
|
||||
|
||||
- the input before the cursor
|
||||
- the input after the cursor *)
|
||||
|
||||
type prompt = Lwt_term.styled_text
|
||||
(** A prompt. It may contains colors. *)
|
||||
|
||||
type text_set = Set.Make(Text).t
|
||||
|
||||
(** {8 Completion} *)
|
||||
|
||||
(** Result of a completion function: *)
|
||||
type completion_result = {
|
||||
comp_state : edition_state;
|
||||
(** The new edition state *)
|
||||
|
||||
comp_words : text_set;
|
||||
(** A list of possibilities *)
|
||||
}
|
||||
|
||||
type completion = edition_state -> completion_result Lwt.t
|
||||
(** Type of a completion function. It takes as argument the
|
||||
current edition state.
|
||||
|
||||
Note: the thread launched by the completion function is
|
||||
cancelled using {!Lwt.cancel} if the user continue typing
|
||||
text. *)
|
||||
|
||||
val lookup : Text.t -> text_set -> (Text.t * text_set)
|
||||
(** [lookup word words] lookup for completion of [word] into
|
||||
[words]. It returns [(prefix, possibilities)] where
|
||||
[possibilities] are all words starting with [word] and [prefix]
|
||||
is the longest common prefix of [possibilities]. *)
|
||||
|
||||
val complete : ?suffix : Text.t -> Text.t -> Text.t -> Text.t -> text_set -> completion_result
|
||||
(** [complete ?suffix before word after words] basic completion
|
||||
functions. [words] is a list of possible completions for
|
||||
[word].
|
||||
|
||||
If completion succeed [suffix] is append to the resulting
|
||||
text. It defaults to [" "]. *)
|
||||
|
||||
val print_words : Lwt_text.output_channel -> int -> string list -> unit Lwt.t
|
||||
(** [print_words oc columns strs] pretty-prints a list of words. *)
|
||||
|
||||
(** {8 History} *)
|
||||
|
||||
type history = Text.t list
|
||||
(** Type of an history *)
|
||||
|
||||
val add_entry : Text.t -> history -> history
|
||||
(** [add_entry line history] returns the history [history] plus
|
||||
[line] at the beginning. If [line] already appears at the
|
||||
beginning or contains only spaces, it is discarded. *)
|
||||
|
||||
val save_history : string -> history -> unit Lwt.t
|
||||
(** [save_history filename history] saves [history] to
|
||||
[filename]. History is saved by separating lines with a null
|
||||
character. *)
|
||||
|
||||
val load_history : string -> history Lwt.t
|
||||
(** [load_history filename] loads history from [filename]. Returns
|
||||
the empty history if the the file does not exit. *)
|
||||
|
||||
(** {8 Clipboards} *)
|
||||
|
||||
(** Type of a clipboard. *)
|
||||
class clipboard : object
|
||||
method set : Text.t -> unit
|
||||
method contents : Text.t React.signal
|
||||
end
|
||||
|
||||
val clipboard : clipboard
|
||||
(** The global clipboard. All read-line instances which do not use a
|
||||
specific clipboard use this one. *)
|
||||
|
||||
(** {6 High-level functions} *)
|
||||
|
||||
type completion_mode = [ `classic | `real_time | `none ]
|
||||
(** The completion mode.
|
||||
|
||||
- [`classic] means that when the user hit [Tab] a list of
|
||||
possible completions is proposed,
|
||||
|
||||
- [`real_time] means that possible completions are shown to
|
||||
the user as he types, and he can navigate in them with
|
||||
[Meta+left], [Meta+right]
|
||||
|
||||
- [`none] means no completion at all *)
|
||||
|
||||
val read_line :
|
||||
?history : history ->
|
||||
?complete : completion ->
|
||||
?clipboard : clipboard ->
|
||||
?mode : completion_mode ->
|
||||
?prompt : prompt -> unit -> Text.t Lwt.t
|
||||
(** [readline ?history ?complete ?mode ?prompt ()] inputs some text
|
||||
from the user. If input is not a terminal, it defaults to
|
||||
[Lwt_text.read_line Lwt_text.stdin].
|
||||
|
||||
If @param mode contains the current completion mode. It defaults
|
||||
to [`real_time].
|
||||
|
||||
@param prompt defaults to [Lwt_term.Text "# "] *)
|
||||
|
||||
type password_style = [ `empty | `clear | `text of Text.t ]
|
||||
(** Style which indicate how the password is echoed to the user:
|
||||
|
||||
- with [`empty] nothing is printed
|
||||
- with [`clear] the password is displayed has it
|
||||
- with [`text ch] all characters are replaced by [ch] *)
|
||||
|
||||
val read_password :
|
||||
?clipboard : clipboard ->
|
||||
?style : password_style ->
|
||||
?prompt : prompt -> unit -> Text.t Lwt.t
|
||||
(** [read_password ?clipboard ?clear ~prompt ()] inputs a password
|
||||
from the user. This function fails if input is not a terminal.
|
||||
|
||||
@param style defaults to [`text "*"].
|
||||
*)
|
||||
|
||||
val read_keyword :
|
||||
?history : history ->
|
||||
?case_sensitive : bool ->
|
||||
?mode : completion_mode ->
|
||||
?prompt : prompt ->
|
||||
values : (Text.t * 'value) list -> unit -> 'value Lwt.t
|
||||
(** [read_keyword ?history ?case_sensitive ?mode ~prompt ~keywords
|
||||
()] reads one word which is a member of [words]. And returns
|
||||
which keyword the user choosed.
|
||||
|
||||
[case_sensitive] default to [false]. *)
|
||||
|
||||
val read_yes_no : ?history : history -> ?mode : completion_mode -> ?prompt : prompt -> unit -> bool Lwt.t
|
||||
(** [read_yes_no ?history ?dynamic prompt ()] is the same as:
|
||||
|
||||
{[
|
||||
read_keyword ?history ?dynamic prompt [("yes", true); ("no", false)] ()
|
||||
]}
|
||||
*)
|
||||
|
||||
(** {6 Low-level interaction} *)
|
||||
|
||||
(** This part allow you to implements your own read-line function, or
|
||||
just to use the readline engine in another context (message box,
|
||||
...). *)
|
||||
|
||||
(** Readline commands *)
|
||||
module Command : sig
|
||||
|
||||
(** Type of all read-line function: *)
|
||||
type t =
|
||||
| Nop
|
||||
(** Command which do nothing. Unknown keys maps to this commands. *)
|
||||
| Char of Text.t
|
||||
(** Any printable character. *)
|
||||
| Backward_delete_char
|
||||
| Forward_delete_char
|
||||
| Beginning_of_line
|
||||
| End_of_line
|
||||
| Complete
|
||||
| Meta_complete
|
||||
| Kill_line
|
||||
| Backward_kill_line
|
||||
| Accept_line
|
||||
| Backward_delete_word
|
||||
| Forward_delete_word
|
||||
| History_next
|
||||
| History_previous
|
||||
| Break
|
||||
| Clear_screen
|
||||
| Insert
|
||||
| Refresh
|
||||
| Backward_char
|
||||
| Forward_char
|
||||
| Set_mark
|
||||
| Paste
|
||||
| Copy
|
||||
| Cut
|
||||
| Uppercase
|
||||
| Lowercase
|
||||
| Capitalize
|
||||
| Backward_word
|
||||
| Forward_word
|
||||
| Backward_search
|
||||
| Complete_left
|
||||
| Complete_right
|
||||
| Complete_up
|
||||
| Complete_down
|
||||
| Complete_first
|
||||
| Complete_last
|
||||
| Undo
|
||||
| Delete_char_or_list
|
||||
|
||||
val to_string : t -> string
|
||||
(** [to_string cmd] returns a string representation of a command *)
|
||||
|
||||
val of_string : string -> t
|
||||
(** [of_string cld] tries to convert a command name to a
|
||||
command. @raise Failure if it fails. *)
|
||||
|
||||
val names : (t * string) list
|
||||
(** [names] is the list of all commands (except [Char ch]) with
|
||||
their name. *)
|
||||
|
||||
val of_key : Lwt_term.key -> t
|
||||
(** [of_key key] returns the command to which a key is mapped. *)
|
||||
end
|
||||
|
||||
(** Engine *)
|
||||
module Engine : sig
|
||||
|
||||
(** Note: this part know nothing about rendering or completion. *)
|
||||
|
||||
(** State when the user is doing selection: *)
|
||||
type selection_state = {
|
||||
sel_text : Text.t;
|
||||
(** The whole input text on which the selection is working *)
|
||||
sel_mark : Text.pointer;
|
||||
(** Pointer to the mark *)
|
||||
sel_cursor : Text.pointer;
|
||||
(** Pointer to the cursor *)
|
||||
}
|
||||
|
||||
(** State when searching in the history *)
|
||||
type search_state = {
|
||||
search_word : Text.t;
|
||||
(** The word we are looking for *)
|
||||
search_history : history;
|
||||
(** Position in history. The first element is a sentence
|
||||
containing the searched word *)
|
||||
search_init_history : history;
|
||||
(** The initial history, before searching for a word *)
|
||||
}
|
||||
|
||||
(** The engine mode: *)
|
||||
type mode =
|
||||
| Edition of edition_state
|
||||
(** The user is typing some text *)
|
||||
| Selection of selection_state
|
||||
(** The user is selecting some text *)
|
||||
| Search of search_state
|
||||
(** The user is searching the given word in the history *)
|
||||
|
||||
(** An engine state: *)
|
||||
type state = {
|
||||
mode : mode;
|
||||
history : history * history;
|
||||
(** Cursor to the history position. *)
|
||||
}
|
||||
|
||||
val init : history -> state
|
||||
(** [init history] return a initial state using the given
|
||||
history *)
|
||||
|
||||
val reset : state -> state
|
||||
(** [reset state] reset the given state, if the user was doing a
|
||||
selection, it is canceled *)
|
||||
|
||||
val update : engine_state : state -> ?clipboard : clipboard -> command : Command.t -> unit -> state
|
||||
(** [update ~state ?clipboard ~command ()] update an engine state by
|
||||
processing the given command. It returns the new state, and
|
||||
may have the side effect of changing the clipboard contents.
|
||||
|
||||
[clipboard] defaults to the global clipboard.
|
||||
*)
|
||||
|
||||
val edition_state : state -> edition_state
|
||||
(** Returns the edition state of a state, whatever its mode is. *)
|
||||
|
||||
val all_input : state -> Text.t
|
||||
(** Returns the current complete user input. *)
|
||||
end
|
||||
|
||||
(** Rendering to the terminal *)
|
||||
module Terminal : sig
|
||||
|
||||
type state
|
||||
(** State of rendering *)
|
||||
|
||||
val init : state
|
||||
(** Initial state *)
|
||||
|
||||
(** The following functions are the one used by read-line functions
|
||||
of this module. *)
|
||||
|
||||
(** Box for the completion: *)
|
||||
type box =
|
||||
| Box_none
|
||||
(** No box at all *)
|
||||
| Box_empty
|
||||
(** An empty box *)
|
||||
| Box_words of text_set * int
|
||||
(** [BM_words(words, position)] is a box with the given list
|
||||
of words. [position] is the position of the selected word
|
||||
in the list.. *)
|
||||
| Box_message of string
|
||||
(** A box containing only the given message *)
|
||||
|
||||
val draw :
|
||||
columns : int ->
|
||||
?map_text : (Text.t -> Text.t) ->
|
||||
?box : box ->
|
||||
render_state : state ->
|
||||
engine_state : Engine.state ->
|
||||
prompt : prompt -> unit -> Lwt_term.styled_text * state
|
||||
(** [draw ~column ?map_text ?bar ~render_state ~engine_state
|
||||
prompt ()] returns [(text, state)] where [state] is the new
|
||||
rendering state, and [text] is a text containing escape
|
||||
sequences. When printed, it will update the displayed state.
|
||||
|
||||
@param map_text is a function used to map user input before
|
||||
printing it, for example to hide passwords.
|
||||
@param message is a message to display if completion is not
|
||||
yet available.
|
||||
@param box defaults to {!Box_none}. *)
|
||||
|
||||
val last_draw :
|
||||
columns : int ->
|
||||
?map_text : (Text.t -> Text.t) ->
|
||||
render_state : state ->
|
||||
engine_state : Engine.state ->
|
||||
prompt : prompt -> unit -> Lwt_term.styled_text
|
||||
(** Draw for the last time, i.e. the cursor is left after the text
|
||||
and not at current position. *)
|
||||
|
||||
val erase : columns : int -> render_state : state -> unit -> Lwt_term.styled_text
|
||||
(** [erase ~columns ~render_state ()] returns a text which will
|
||||
erase everything (the prompt, user input, completion, ...).
|
||||
|
||||
After an erase, the rendering state is [init]. *)
|
||||
end
|
||||
|
||||
(** {6 Advanced use} *)
|
||||
|
||||
(** Controlling a running read-line instance *)
|
||||
module Control : sig
|
||||
|
||||
type 'a t
|
||||
(** Type of a running read-line instance, returning a value of
|
||||
type ['a] *)
|
||||
|
||||
(** {6 Control} *)
|
||||
|
||||
val result : 'a t -> 'a Lwt.t
|
||||
(** Threads waiting for the read-line instance to terminates *)
|
||||
|
||||
val send_command : 'a t -> Command.t -> unit
|
||||
(** [send_command instance command] sends the given command to the
|
||||
read-line instance *)
|
||||
|
||||
val accept : 'a t -> unit
|
||||
(** [accept instance = send_command instance Command.Accept_line] *)
|
||||
|
||||
val interrupt : 'a t -> unit
|
||||
(** [accept instance = send_command instance Command.Break] *)
|
||||
|
||||
val hide : 'a t -> unit Lwt.t
|
||||
(** Hides everything (prompt, user input, completion box) until
|
||||
{!show} is called. *)
|
||||
|
||||
val show : 'a t -> unit Lwt.t
|
||||
(** Un-hide everything *)
|
||||
|
||||
(** Note: in case the input is not a terminal, read-line instances
|
||||
are not controllable. i.e. {!accept}, {!refresh}, ... have no
|
||||
effect. *)
|
||||
|
||||
(** {6 Creation of read-line instances} *)
|
||||
|
||||
type prompt = Engine.state React.signal -> Lwt_term.styled_text React.signal
|
||||
(** The prompt a signal which may depends on the engine state *)
|
||||
|
||||
type state
|
||||
(** State of an instance *)
|
||||
|
||||
val engine_state : state -> Engine.state
|
||||
(** Return the engine state of the given state *)
|
||||
|
||||
val render_state : state -> Terminal.state
|
||||
(** Return the rendering state of the given state *)
|
||||
|
||||
val make :
|
||||
?history : history ->
|
||||
?complete : completion ->
|
||||
?clipboard : clipboard ->
|
||||
?mode : [ completion_mode | `none ] ->
|
||||
?map_text : (Text.t -> Text.t) ->
|
||||
?filter : (state -> Command.t -> Command.t Lwt.t) ->
|
||||
map_result : (Text.t -> 'a Lwt.t) ->
|
||||
?prompt : prompt -> unit -> 'a t
|
||||
(** Creates a new read-line instance with the given
|
||||
parameters. [filter] is called to handle commands. You can
|
||||
return {!Command.Nop} to drop a command. *)
|
||||
|
||||
(** {6 Predefined instances} *)
|
||||
|
||||
val read_line :
|
||||
?history : history ->
|
||||
?complete : completion ->
|
||||
?clipboard : clipboard ->
|
||||
?mode : completion_mode ->
|
||||
?prompt : prompt -> unit -> Text.t t Lwt.t
|
||||
|
||||
val read_password :
|
||||
?clipboard : clipboard ->
|
||||
?style : password_style ->
|
||||
?prompt : prompt -> unit -> Text.t t Lwt.t
|
||||
|
||||
val read_keyword :
|
||||
?history : history ->
|
||||
?case_sensitive : bool ->
|
||||
?mode : completion_mode ->
|
||||
?prompt : prompt ->
|
||||
values : (Text.t * 'value) list -> unit -> 'value t Lwt.t
|
||||
|
||||
val read_yes_no :
|
||||
?history : history ->
|
||||
?mode : completion_mode ->
|
||||
?prompt : prompt -> unit -> bool t Lwt.t
|
||||
end
|
|
@ -0,0 +1,847 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Module Lwt_term
|
||||
* Copyright (C) 2009 Jérémie Dimino
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
open Lwt
|
||||
open Lwt_text
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Terminal mode |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
type state =
|
||||
| Normal
|
||||
| Raw of Unix.terminal_io
|
||||
|
||||
let state = ref Normal
|
||||
|
||||
(* Number of function currently using the raw mode: *)
|
||||
let raw_count = ref 0
|
||||
|
||||
let get_attr () =
|
||||
try_lwt
|
||||
lwt attr = Lwt_unix.tcgetattr Lwt_unix.stdin in
|
||||
return (Some attr)
|
||||
with _ ->
|
||||
return None
|
||||
|
||||
let set_attr mode =
|
||||
try_lwt
|
||||
Lwt_unix.tcsetattr Lwt_unix.stdin Unix.TCSAFLUSH mode
|
||||
with _ ->
|
||||
return ()
|
||||
|
||||
let drawing_mode = ref false
|
||||
|
||||
let enter_drawing_mode () =
|
||||
drawing_mode := true;
|
||||
write stdout "\027[?1049h\027[?1h\027=\r"
|
||||
|
||||
let leave_drawing_mode () =
|
||||
drawing_mode := false;
|
||||
write stdout "\r\027[K\027[?1l\027>\027[r\027[?1049l"
|
||||
|
||||
let cursor_visible = ref true
|
||||
|
||||
let show_cursor _ =
|
||||
cursor_visible := true;
|
||||
write stdout "\x1B[?25h"
|
||||
|
||||
let hide_cursor _ =
|
||||
cursor_visible := false;
|
||||
write stdout "\x1B[?25l"
|
||||
|
||||
let clear_screen _ =
|
||||
write stdout "\027[2J\027[H"
|
||||
|
||||
let clear_line _ =
|
||||
write stdout "\027[2K"
|
||||
|
||||
(* Go-up by [n] lines then to the beginning of the line. Normally
|
||||
"\027[nF" does exactly this but for some terminal 1 need to be
|
||||
added... By the way we can relly on the fact that all terminal
|
||||
react the same way to "\027[F" which is to go to the beginning of
|
||||
the previous line: *)
|
||||
let rec goto_beginning_of_line = function
|
||||
| 0 ->
|
||||
write_char stdout "\r"
|
||||
| 1 ->
|
||||
write stdout "\027[F"
|
||||
| n ->
|
||||
lwt () = write stdout "\027[F" in
|
||||
goto_beginning_of_line (n - 1)
|
||||
|
||||
(* Restore terminal mode on exit: *)
|
||||
let cleanup () =
|
||||
lwt () =
|
||||
if not !cursor_visible then
|
||||
show_cursor ()
|
||||
else
|
||||
return ()
|
||||
in
|
||||
lwt () =
|
||||
if !drawing_mode then
|
||||
leave_drawing_mode ()
|
||||
else
|
||||
return ()
|
||||
in
|
||||
match !state with
|
||||
| Normal ->
|
||||
return ()
|
||||
| Raw saved_attr ->
|
||||
set_attr saved_attr
|
||||
|
||||
let () = Lwt_main.at_exit cleanup
|
||||
|
||||
let raw_mode () = match !state with
|
||||
| Normal -> false
|
||||
| Raw _ -> true
|
||||
|
||||
let leave_raw_mode () =
|
||||
decr raw_count;
|
||||
if !raw_count = 0 then
|
||||
match !state with
|
||||
| Normal ->
|
||||
assert false
|
||||
| Raw attr ->
|
||||
state := Normal;
|
||||
set_attr attr
|
||||
else
|
||||
return ()
|
||||
|
||||
let with_raw_mode f =
|
||||
match !state with
|
||||
| Raw attr ->
|
||||
incr raw_count;
|
||||
finalize f leave_raw_mode
|
||||
| Normal ->
|
||||
get_attr () >>= function
|
||||
| Some attr ->
|
||||
incr raw_count;
|
||||
state := Raw attr;
|
||||
lwt () = set_attr {
|
||||
attr with
|
||||
(* Inspired from Python-3.0/Lib/tty.py: *)
|
||||
Unix.c_brkint = false;
|
||||
Unix.c_inpck = false;
|
||||
Unix.c_istrip = false;
|
||||
Unix.c_ixon = false;
|
||||
Unix.c_csize = 8;
|
||||
Unix.c_parenb = false;
|
||||
Unix.c_echo = false;
|
||||
Unix.c_icanon = false;
|
||||
Unix.c_isig = false;
|
||||
Unix.c_vmin = 1;
|
||||
Unix.c_vtime = 0
|
||||
} in
|
||||
try_lwt f () finally leave_raw_mode ()
|
||||
| None ->
|
||||
raise_lwt (Failure "Lwt_term.with_raw_mode: input is not a tty")
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Terminal informations |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
type size = {
|
||||
lines : int;
|
||||
columns : int;
|
||||
}
|
||||
|
||||
external get_size : Unix.file_descr -> size = "lwt_text_term_size"
|
||||
|
||||
#if windows
|
||||
|
||||
let size =
|
||||
React.S.const
|
||||
(try
|
||||
get_size Unix.stdout
|
||||
with Unix.Unix_error _ ->
|
||||
{ columns = 80; lines = 25 })
|
||||
|
||||
#else
|
||||
|
||||
external sigwinch : unit -> int = "lwt_text_sigwinch"
|
||||
let sigwinch = sigwinch ()
|
||||
|
||||
let sigwinch_event =
|
||||
if sigwinch = 0 then
|
||||
React.E.never
|
||||
else
|
||||
try
|
||||
let event, push = React.E.create () in
|
||||
let _ = Lwt_unix.on_signal sigwinch push in
|
||||
event
|
||||
with Unix.Unix_error _ | Invalid_argument _ | Sys_error _ ->
|
||||
React.E.never
|
||||
|
||||
let size =
|
||||
React.S.hold
|
||||
(try
|
||||
get_size Unix.stdin
|
||||
with Unix.Unix_error _ ->
|
||||
{ columns = 80; lines = 25 })
|
||||
(React.E.map (fun _ -> get_size Unix.stdin) sigwinch_event)
|
||||
|
||||
#endif
|
||||
|
||||
let columns = React.S.map (fun { columns = c } -> c) size
|
||||
let lines = React.S.map (fun { lines = l } -> l) size
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Keys input |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
exception Exit_sequence
|
||||
|
||||
let parse_escape st =
|
||||
let buf = Buffer.create 10 in
|
||||
Buffer.add_char buf '\027';
|
||||
(* Read one character and add it to [buf]: *)
|
||||
let get () =
|
||||
match Lwt.state (Lwt_stream.get st) with
|
||||
| Sleep ->
|
||||
(* If the rest is not immediatly available, conclude that
|
||||
this is not an escape sequence but just the escape key: *)
|
||||
raise_lwt Exit_sequence
|
||||
| Fail exn ->
|
||||
raise_lwt exn
|
||||
| Return None ->
|
||||
raise_lwt Exit_sequence
|
||||
| Return(Some ch) ->
|
||||
(* Is it an ascii character ? *)
|
||||
if String.length ch = 1 then begin
|
||||
Buffer.add_string buf ch;
|
||||
return ch.[0]
|
||||
end else
|
||||
(* If it is not, then this is not an escape sequence: *)
|
||||
raise_lwt Exit_sequence
|
||||
in
|
||||
|
||||
(* Sometimes sequences starts with several escape characters: *)
|
||||
let rec first count =
|
||||
get () >>= function
|
||||
| '\027' when count < 3 ->
|
||||
first (count + 1)
|
||||
| ch ->
|
||||
return ch
|
||||
in
|
||||
|
||||
first 0 >>= function
|
||||
| '[' | 'O' ->
|
||||
let rec loop () =
|
||||
get () >>= function
|
||||
| '0' .. '9' | ';' ->
|
||||
loop ()
|
||||
| ch ->
|
||||
return (Buffer.contents buf)
|
||||
in
|
||||
loop ()
|
||||
|
||||
| ch ->
|
||||
return (Buffer.contents buf)
|
||||
|
||||
let parse_key_raw st =
|
||||
Lwt_stream.next st >>= function
|
||||
| "\027" ->
|
||||
begin
|
||||
try_lwt
|
||||
Lwt_stream.parse st parse_escape
|
||||
with
|
||||
Exit_sequence -> return "\027"
|
||||
end
|
||||
| ch ->
|
||||
return ch
|
||||
|
||||
type key =
|
||||
| Key of string
|
||||
| Key_up
|
||||
| Key_down
|
||||
| Key_left
|
||||
| Key_right
|
||||
| Key_f of int
|
||||
| Key_next_page
|
||||
| Key_previous_page
|
||||
| Key_home
|
||||
| Key_end
|
||||
| Key_insert
|
||||
| Key_delete
|
||||
| Key_control of char
|
||||
|
||||
let key_enter = Key_control 'j'
|
||||
let key_escape = Key_control '['
|
||||
let key_tab = Key_control 'i'
|
||||
let key_backspace = Key_control '?'
|
||||
|
||||
let string_of_key = function
|
||||
| Key ch ->
|
||||
Printf.sprintf "Key %S" ch
|
||||
| Key_f n ->
|
||||
Printf.sprintf "Key_f %d" n
|
||||
| Key_control c ->
|
||||
Printf.sprintf "Key_control %C" c
|
||||
| Key_up ->
|
||||
"Key_up"
|
||||
| Key_down ->
|
||||
"Key_down"
|
||||
| Key_left ->
|
||||
"Key_left"
|
||||
| Key_right ->
|
||||
"Key_right"
|
||||
| Key_next_page ->
|
||||
"Key_next_page"
|
||||
| Key_previous_page ->
|
||||
"Key_previous_page"
|
||||
| Key_home ->
|
||||
"Key_home"
|
||||
| Key_end ->
|
||||
"Key_end"
|
||||
| Key_insert ->
|
||||
"Key_insert"
|
||||
| Key_delete ->
|
||||
"Key_delete"
|
||||
|
||||
let sequence_mapping = [
|
||||
"\027[A", Key_up;
|
||||
"\027[B", Key_down;
|
||||
"\027[C", Key_right;
|
||||
"\027[D", Key_left;
|
||||
"\027A", Key_up;
|
||||
"\027B", Key_down;
|
||||
"\027C", Key_right;
|
||||
"\027D", Key_left;
|
||||
"\027OA", Key_up;
|
||||
"\027OB", Key_down;
|
||||
"\027OC", Key_right;
|
||||
"\027OD", Key_left;
|
||||
"\027[2~", Key_insert;
|
||||
"\027[3~", Key_delete;
|
||||
"\027[5~", Key_previous_page;
|
||||
"\027[6~", Key_next_page;
|
||||
"\027[7~", Key_home;
|
||||
"\027[8~", Key_end;
|
||||
"\027[11~", Key_f 1;
|
||||
"\027[12~", Key_f 2;
|
||||
"\027[13~", Key_f 3;
|
||||
"\027[14~", Key_f 4;
|
||||
"\027[15~", Key_f 5;
|
||||
"\027[17~", Key_f 6;
|
||||
"\027[18~", Key_f 7;
|
||||
"\027[19~", Key_f 8;
|
||||
"\027[20~", Key_f 9;
|
||||
"\027[21~", Key_f 10;
|
||||
"\027[23~", Key_f 11;
|
||||
"\027[24~", Key_f 12;
|
||||
"\027OP", Key_f 1;
|
||||
"\027OQ", Key_f 2;
|
||||
"\027OR", Key_f 3;
|
||||
"\027OS", Key_f 4;
|
||||
"\027[H", Key_home;
|
||||
"\027[F", Key_end;
|
||||
"\027OH", Key_home;
|
||||
"\027OF", Key_end;
|
||||
"\027H", Key_home;
|
||||
"\027F", Key_end;
|
||||
]
|
||||
|
||||
let control_mapping = [
|
||||
0x00, '@';
|
||||
0x01, 'a';
|
||||
0x02, 'b';
|
||||
0x03, 'c';
|
||||
0x04, 'd';
|
||||
0x05, 'e';
|
||||
0x06, 'f';
|
||||
0x07, 'g';
|
||||
0x08, 'h';
|
||||
0x09, 'i';
|
||||
0x0A, 'j';
|
||||
0x0B, 'k';
|
||||
0x0C, 'l';
|
||||
0x0D, 'm';
|
||||
0x0E, 'n';
|
||||
0x0F, 'o';
|
||||
0x10, 'p';
|
||||
0x11, 'q';
|
||||
0x12, 'r';
|
||||
0x13, 's';
|
||||
0x14, 't';
|
||||
0x15, 'u';
|
||||
0x16, 'v';
|
||||
0x17, 'w';
|
||||
0x18, 'x';
|
||||
0x19, 'y';
|
||||
0x1A, 'z';
|
||||
0x1B, '[';
|
||||
0x1C, '\\';
|
||||
0x1D, ']';
|
||||
0x1E, '^';
|
||||
0x1F, '_';
|
||||
0x7F, '?';
|
||||
]
|
||||
|
||||
let decode_key ch =
|
||||
if ch = "" then invalid_arg "Lwt_term.decode_key";
|
||||
match ch with
|
||||
| ch when String.length ch = 1 ->
|
||||
begin try
|
||||
Key_control(List.assoc (Char.code ch.[0]) control_mapping)
|
||||
with
|
||||
Not_found -> Key ch
|
||||
end
|
||||
| ch ->
|
||||
begin try
|
||||
List.assoc ch sequence_mapping
|
||||
with
|
||||
Not_found -> Key ch
|
||||
end
|
||||
|
||||
let standard_input = Lwt_text.read_chars Lwt_text.stdin
|
||||
|
||||
let read_key () =
|
||||
with_raw_mode (fun _ -> parse_key_raw standard_input >|= decode_key)
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Styles |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
type color = int
|
||||
|
||||
let default = -1
|
||||
let black = 0
|
||||
let red = 1
|
||||
let green = 2
|
||||
let yellow = 3
|
||||
let blue = 4
|
||||
let magenta = 5
|
||||
let cyan = 6
|
||||
let white = 7
|
||||
let lblack = black + 8
|
||||
let lred = red + 8
|
||||
let lgreen = green + 8
|
||||
let lyellow = yellow + 8
|
||||
let lblue = blue + 8
|
||||
let lmagenta = magenta + 8
|
||||
let lcyan = cyan + 8
|
||||
let lwhite = white + 8
|
||||
|
||||
type style = {
|
||||
bold : bool;
|
||||
underlined : bool;
|
||||
blink : bool;
|
||||
inverse : bool;
|
||||
hidden : bool;
|
||||
foreground : color;
|
||||
background : color;
|
||||
}
|
||||
|
||||
module Codes = struct
|
||||
let reset = 0
|
||||
let bold = 1
|
||||
let underlined = 4
|
||||
let blink = 5
|
||||
let inverse = 7
|
||||
let hidden = 8
|
||||
let foreground col = 30 + col
|
||||
let background col = 40 + col
|
||||
end
|
||||
|
||||
let set_color num (r, g, b) =
|
||||
write stdout (Printf.sprintf "\027]4;%d;rgb:%02x/%02x/%02x;\027\\" num r g b)
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Rendering |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
type point = {
|
||||
char : string;
|
||||
style : style;
|
||||
}
|
||||
|
||||
let blank = {
|
||||
char = " ";
|
||||
style = {
|
||||
bold = false;
|
||||
underlined = false;
|
||||
blink = false;
|
||||
inverse = false;
|
||||
hidden = false;
|
||||
foreground = default;
|
||||
background = default;
|
||||
};
|
||||
}
|
||||
|
||||
let rec add_int buf = function
|
||||
| 0 ->
|
||||
()
|
||||
| n ->
|
||||
add_int buf (n / 10);
|
||||
Buffer.add_char buf (Char.unsafe_chr (48 + (n mod 10)))
|
||||
|
||||
let render_char buf oc pt last_style =
|
||||
lwt () =
|
||||
if pt.style <> last_style then begin
|
||||
Buffer.clear buf;
|
||||
Buffer.add_string buf "\027[0";
|
||||
let mode n = function
|
||||
| true ->
|
||||
Buffer.add_char buf ';';
|
||||
add_int buf n
|
||||
| false ->
|
||||
()
|
||||
and color f col =
|
||||
if col = default then
|
||||
()
|
||||
else if col < 8 then begin
|
||||
Buffer.add_char buf ';';
|
||||
add_int buf (f col)
|
||||
end else begin
|
||||
Buffer.add_char buf ';';
|
||||
add_int buf (f 8);
|
||||
Buffer.add_string buf ";5;";
|
||||
add_int buf col;
|
||||
end
|
||||
in
|
||||
mode Codes.bold pt.style.bold;
|
||||
mode Codes.underlined pt.style.underlined;
|
||||
mode Codes.blink pt.style.blink;
|
||||
mode Codes.inverse pt.style.inverse;
|
||||
mode Codes.hidden pt.style.hidden;
|
||||
color Codes.foreground pt.style.foreground;
|
||||
color Codes.background pt.style.background;
|
||||
Buffer.add_char buf 'm';
|
||||
write oc (Buffer.contents buf)
|
||||
end else
|
||||
return ()
|
||||
in
|
||||
write_char oc pt.char
|
||||
|
||||
let render_update old m =
|
||||
let buf = Buffer.create 16 in
|
||||
Lwt_text.atomic begin fun oc ->
|
||||
let rec loop_y y last_style =
|
||||
if y < Array.length m then
|
||||
let rec loop_x x last_style =
|
||||
if x < Array.length m.(y) then
|
||||
let pt = m.(y).(x) in
|
||||
lwt () = render_char buf oc pt last_style in
|
||||
loop_x (x + 1) pt.style
|
||||
else
|
||||
loop_y (y + 1) last_style
|
||||
in
|
||||
if y < Array.length old && old.(y) = m.(y) then begin
|
||||
if y + 1 < Array.length m then
|
||||
lwt last_style =
|
||||
if Array.length m.(y) > 0 then
|
||||
let pt = m.(y).(0) in
|
||||
lwt () = render_char buf oc pt last_style in
|
||||
return pt.style
|
||||
else
|
||||
return last_style
|
||||
in
|
||||
lwt () = write oc "\r\n" in
|
||||
loop_y (y + 1) last_style
|
||||
else
|
||||
return ()
|
||||
end else
|
||||
loop_x 0 last_style
|
||||
else
|
||||
return ()
|
||||
in
|
||||
(* Go to the top-left corner and reset attributes: *)
|
||||
lwt () = write oc "\027[H\027[0m" in
|
||||
lwt () = loop_y 0 blank.style in
|
||||
write oc "\027[0m"
|
||||
end stdout
|
||||
|
||||
let render m = render_update [||] m
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Styled text |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
open Printf
|
||||
|
||||
type styled_text_instruction =
|
||||
| Text of Text.t
|
||||
| Reset
|
||||
| Bold
|
||||
| Underlined
|
||||
| Blink
|
||||
| Inverse
|
||||
| Hidden
|
||||
| Foreground of color
|
||||
| Background of color
|
||||
|
||||
type styled_text = styled_text_instruction list
|
||||
|
||||
let textf fmt = Printf.ksprintf (fun txt -> Text txt) fmt
|
||||
let text txt = Text txt
|
||||
let reset = Reset
|
||||
let bold = Bold
|
||||
let underlined = Underlined
|
||||
let blink = Blink
|
||||
let inverse = Inverse
|
||||
let hidden = Hidden
|
||||
let fg col = Foreground col
|
||||
let bg col = Background col
|
||||
|
||||
let strip_styles st =
|
||||
let buf = Buffer.create 42 in
|
||||
List.iter (function
|
||||
| Text t -> Buffer.add_string buf t
|
||||
| _ -> ()) st;
|
||||
Buffer.contents buf
|
||||
|
||||
let write_styled oc st =
|
||||
let buf = Buffer.create 16
|
||||
|
||||
(* Pendings style codes: *)
|
||||
and codes = Queue.create () in
|
||||
|
||||
(* Output pending codes using only one escape sequence: *)
|
||||
let output_pendings () =
|
||||
Buffer.clear buf;
|
||||
Buffer.add_string buf "\027[";
|
||||
add_int buf (Queue.take codes);
|
||||
Queue.iter (fun code ->
|
||||
Buffer.add_char buf ';';
|
||||
add_int buf code) codes;
|
||||
Queue.clear codes;
|
||||
Buffer.add_char buf 'm';
|
||||
write oc (Buffer.contents buf)
|
||||
in
|
||||
|
||||
let rec loop = function
|
||||
| [] ->
|
||||
if not (Queue.is_empty codes) then
|
||||
output_pendings ()
|
||||
else
|
||||
return ()
|
||||
| instr :: rest ->
|
||||
match instr with
|
||||
| Text t ->
|
||||
if not (Queue.is_empty codes) then
|
||||
lwt () = output_pendings () in
|
||||
lwt () = write oc t in
|
||||
loop rest
|
||||
else
|
||||
lwt () = write oc t in
|
||||
loop rest
|
||||
| Reset ->
|
||||
Queue.add 0 codes;
|
||||
loop rest
|
||||
| Bold ->
|
||||
Queue.add Codes.bold codes;
|
||||
loop rest
|
||||
| Underlined ->
|
||||
Queue.add Codes.underlined codes;
|
||||
loop rest
|
||||
| Blink ->
|
||||
Queue.add Codes.blink codes;
|
||||
loop rest
|
||||
| Inverse ->
|
||||
Queue.add Codes.inverse codes;
|
||||
loop rest
|
||||
| Hidden ->
|
||||
Queue.add Codes.hidden codes;
|
||||
loop rest
|
||||
| Foreground col ->
|
||||
if col = default then
|
||||
Queue.add (Codes.foreground 9) codes
|
||||
else if col < 8 then
|
||||
Queue.add (Codes.foreground col) codes
|
||||
else begin
|
||||
Queue.add (Codes.foreground 8) codes;
|
||||
Queue.add 5 codes;
|
||||
Queue.add col codes
|
||||
end;
|
||||
loop rest
|
||||
| Background col ->
|
||||
if col = default then
|
||||
Queue.add (Codes.background 9) codes
|
||||
else if col < 8 then
|
||||
Queue.add (Codes.background col) codes
|
||||
else begin
|
||||
Queue.add (Codes.background 8) codes;
|
||||
Queue.add 5 codes;
|
||||
Queue.add col codes
|
||||
end;
|
||||
loop rest
|
||||
in
|
||||
loop st
|
||||
|
||||
let styled_length st =
|
||||
let rec loop len = function
|
||||
| [] -> len
|
||||
| Text t :: l -> loop (len + Text.length t) l
|
||||
| _ :: l -> loop len l
|
||||
in
|
||||
loop 0 st
|
||||
|
||||
let printc st =
|
||||
Lwt_unix.isatty Lwt_unix.stdout >>= function
|
||||
| true ->
|
||||
atomic (fun oc -> write_styled oc st) stdout
|
||||
| false ->
|
||||
write stdout (strip_styles st)
|
||||
|
||||
let eprintc st =
|
||||
Lwt_unix.isatty Lwt_unix.stderr >>= function
|
||||
| true ->
|
||||
atomic (fun oc -> write_styled oc st) stderr
|
||||
| false ->
|
||||
write stderr (strip_styles st)
|
||||
|
||||
let fprintlc oc fd st =
|
||||
Lwt_unix.isatty fd >>= function
|
||||
| true ->
|
||||
atomic (fun oc ->
|
||||
lwt () = write_styled oc st in
|
||||
lwt () = write oc "\027[m" in
|
||||
write_char oc "\n") oc
|
||||
| false ->
|
||||
write_line oc (strip_styles st)
|
||||
|
||||
let printlc st = fprintlc stdout Lwt_unix.stdout st
|
||||
let eprintlc st = fprintlc stderr Lwt_unix.stderr st
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Drawing |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
module Zone =
|
||||
struct
|
||||
type t = {
|
||||
points : point array array;
|
||||
x : int;
|
||||
y : int;
|
||||
width : int;
|
||||
height : int;
|
||||
}
|
||||
|
||||
let points zone = zone.points
|
||||
let x zone = zone.x
|
||||
let y zone = zone.y
|
||||
let width zone = zone.width
|
||||
let height zone = zone.height
|
||||
|
||||
let make ~width ~height =
|
||||
if width < 0 || height < 0 then invalid_arg "Lwt_term.Zone.make";
|
||||
{
|
||||
points = Array.make_matrix height width blank;
|
||||
x = 0;
|
||||
y = 0;
|
||||
width = width;
|
||||
height = height;
|
||||
}
|
||||
|
||||
let sub ~zone ~x ~y ~width ~height =
|
||||
if (x < 0 || y < 0 ||
|
||||
width < 0 || height < 0 ||
|
||||
x + width > zone.width ||
|
||||
y + height > zone.height) then
|
||||
invalid_arg "Lwt_term.Zone.sub";
|
||||
{
|
||||
points = zone.points;
|
||||
x = zone.x + x;
|
||||
y = zone.y + y;
|
||||
width = width;
|
||||
height = height;
|
||||
}
|
||||
|
||||
let inner zone = {
|
||||
points = zone.points;
|
||||
x = if zone.width >= 2 then zone.x + 1 else zone.x;
|
||||
y = if zone.height >= 2 then zone.y + 1 else zone.y;
|
||||
width = if zone.width >= 2 then zone.width - 2 else zone.width;
|
||||
height = if zone.height >= 2 then zone.height - 2 else zone.height;
|
||||
}
|
||||
end
|
||||
|
||||
module Draw =
|
||||
struct
|
||||
open Zone
|
||||
|
||||
let get ~zone ~x ~y =
|
||||
if x < 0 || y < 0 || x >= zone.width || y >= zone.height then
|
||||
invalid_arg "Lwt_term.Draw.get";
|
||||
zone.points.(zone.y + y).(zone.x + x)
|
||||
|
||||
let set ~zone ~x ~y ~point =
|
||||
if x < 0 || y < 0 || x >= zone.width || y >= zone.height then
|
||||
()
|
||||
else
|
||||
zone.points.(zone.y + y).(zone.x + x) <- point
|
||||
|
||||
let map ~zone ~x ~y f =
|
||||
if x < 0 || y < 0 || x >= zone.width || y >= zone.height then
|
||||
()
|
||||
else
|
||||
let x = zone.x + x and y = zone.y + y in
|
||||
zone.points.(y).(x) <- f zone.points.(y).(x)
|
||||
|
||||
let text ~zone ~x ~y ~text =
|
||||
let rec loop x ptr = match Text.next ptr with
|
||||
| Some(ch, ptr) ->
|
||||
set zone x y { blank with char = ch };
|
||||
loop (x + 1) ptr
|
||||
| None ->
|
||||
()
|
||||
in
|
||||
loop x (Text.pointer_l text)
|
||||
|
||||
let textf zone x y fmt =
|
||||
Printf.ksprintf (fun txt -> text zone x y txt) fmt
|
||||
|
||||
let textc ~zone ~x ~y ~text =
|
||||
let rec loop style x = function
|
||||
| [] ->
|
||||
()
|
||||
| instr :: rest ->
|
||||
match instr with
|
||||
| Text text ->
|
||||
loop_text style x (Text.pointer_l text) rest
|
||||
| Reset ->
|
||||
loop blank.style x rest
|
||||
| Bold ->
|
||||
loop { style with bold = true } x rest
|
||||
| Underlined ->
|
||||
loop { style with underlined = true } x rest
|
||||
| Blink ->
|
||||
loop { style with blink = true } x rest
|
||||
| Inverse ->
|
||||
loop { style with inverse = true } x rest
|
||||
| Hidden ->
|
||||
loop { style with hidden = true } x rest
|
||||
| Foreground color ->
|
||||
loop { style with foreground = color } x rest
|
||||
| Background color ->
|
||||
loop { style with background = color } x rest
|
||||
and loop_text style x ptr rest =
|
||||
match Text.next ptr with
|
||||
| Some(ch, ptr) ->
|
||||
set zone x y { char = ch; style = style };
|
||||
loop_text style (x + 1) ptr rest
|
||||
| None ->
|
||||
loop style x rest
|
||||
in
|
||||
loop blank.style x text
|
||||
end
|
|
@ -0,0 +1,393 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Module Lwt_term
|
||||
* Copyright (C) 2009 Jérémie Dimino
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
(** Terminal control *)
|
||||
|
||||
(** This modules allow you to write interactive programs using the
|
||||
terminal. *)
|
||||
|
||||
val with_raw_mode : (unit -> 'a Lwt.t) -> 'a Lwt.t
|
||||
(** [with_raw_mode f] executes [f] while the terminal is in ``raw
|
||||
mode''. Raw mode means that character are returned as the user
|
||||
type them (otherwise only complete line are returned to the
|
||||
program).
|
||||
|
||||
If the terminal is already in raw mode, it just calls [f]. *)
|
||||
|
||||
val raw_mode : unit -> bool
|
||||
(** Returns wether the terminal is currently in raw mode *)
|
||||
|
||||
val enter_drawing_mode : unit -> unit Lwt.t
|
||||
(** Put the terminal into drawing mode *)
|
||||
|
||||
val leave_drawing_mode : unit -> unit Lwt.t
|
||||
(** Restore the state of the terminal *)
|
||||
|
||||
val show_cursor : unit -> unit Lwt.t
|
||||
(** [show_cursor ()] makes the cursor visible *)
|
||||
|
||||
val hide_cursor : unit -> unit Lwt.t
|
||||
(** [hide_cursor ()] makes the cursor invisible *)
|
||||
|
||||
val clear_screen : unit -> unit Lwt.t
|
||||
(** [clear_screen ()] clears the entire screen *)
|
||||
|
||||
val clear_line : unit -> unit Lwt.t
|
||||
(** [clear_line ()] clears the current line *)
|
||||
|
||||
val goto_beginning_of_line : int -> unit Lwt.t
|
||||
(** [goto_beginning_of_line n] put the cursor at the beginning of
|
||||
the [n]th previous line.
|
||||
|
||||
- [goto_beginning_of_line 0] goes to the beginning of the current line
|
||||
- [goto_beginning_of_line 1] goes to the beginning of the previous line
|
||||
- ...
|
||||
*)
|
||||
|
||||
(** {6 Terminal informations} *)
|
||||
|
||||
(** Terminal sizes: *)
|
||||
type size = {
|
||||
lines : int;
|
||||
columns : int;
|
||||
}
|
||||
|
||||
val size : size React.signal
|
||||
(** Size of the terminal. *)
|
||||
|
||||
val columns : int React.signal
|
||||
(** Number of columns of the terminal *)
|
||||
|
||||
val lines : int React.signal
|
||||
(** Number of lines of the terminal *)
|
||||
|
||||
(** {6 Keys} *)
|
||||
|
||||
val parse_key_raw : Text.t Lwt_stream.t -> Text.t Lwt.t
|
||||
(** [parse_key_raw st] recognize escape sequence in a stream of
|
||||
unicode character.
|
||||
|
||||
It returns either:
|
||||
- either single characters, like ["a"], ["é"], ...
|
||||
- either escape sequences
|
||||
*)
|
||||
|
||||
(** Type of ``decoded'' keys.
|
||||
|
||||
This list is not exhaustive, but at least it should works on all
|
||||
terminals: *)
|
||||
type key =
|
||||
| Key of Text.t
|
||||
(** A unicode character or an uninterpreted sequence *)
|
||||
| Key_up
|
||||
| Key_down
|
||||
| Key_left
|
||||
| Key_right
|
||||
| Key_f of int
|
||||
| Key_next_page
|
||||
| Key_previous_page
|
||||
| Key_home
|
||||
| Key_end
|
||||
| Key_insert
|
||||
| Key_delete
|
||||
| Key_control of char
|
||||
(** A control key *)
|
||||
|
||||
val string_of_key : key -> string
|
||||
(** [string_of_key key] string representation of a key *)
|
||||
|
||||
val control_mapping : (int * char) list
|
||||
(** Mapping from control key codes to character codes.
|
||||
|
||||
Here is the list of control keys:
|
||||
|
||||
{[
|
||||
+------+-------+------+------+------+-------+------------------------------------------------+
|
||||
| Char | Oct | Dec | Name | Hex | Key | Comment |
|
||||
+------+-------+------+------+------+-------+------------------------------------------------+
|
||||
| '@' | 0o00 | 0 | NUL | 0x00 | ^@ \0 | Null byte |
|
||||
| 'a' | 0o01 | 1 | SOH | 0x01 | ^A | Start of heading |
|
||||
| 'b' | 0o02 | 2 | STX | 0x02 | ^B | Start of text |
|
||||
| 'c' | 0o03 | 3 | ETX | 0x03 | ^C | End of text |
|
||||
| 'd' | 0o04 | 4 | EOT | 0x04 | ^D | End of transmission |
|
||||
| 'e' | 0o05 | 5 | ENQ | 0x05 | ^E | Enquiry |
|
||||
| 'f' | 0o06 | 6 | ACK | 0x06 | ^F | Acknowledge |
|
||||
| 'g' | 0o07 | 7 | BEL | 0x07 | ^G | Ring terminal bell |
|
||||
| 'h' | 0o10 | 8 | BS | 0x08 | ^H \b | Backspace |
|
||||
| 'i' | 0o11 | 9 | HT | 0x09 | ^I \t | Horizontal tab |
|
||||
| 'j' | 0o12 | 10 | LF | 0x0a | ^J \n | Line feed |
|
||||
| 'k' | 0o13 | 11 | VT | 0x0b | ^K | Vertical tab |
|
||||
| 'l' | 0o14 | 12 | FF | 0x0c | ^L \f | Form feed |
|
||||
| 'm' | 0o15 | 13 | CR | 0x0d | ^M \r | Carriage return |
|
||||
| 'n' | 0o16 | 14 | SO | 0x0e | ^N | Shift out |
|
||||
| 'o' | 0o17 | 15 | SI | 0x0f | ^O | Shift in |
|
||||
| 'p' | 0o20 | 16 | DLE | 0x10 | ^P | Data link escape |
|
||||
| 'q' | 0o21 | 17 | DC1 | 0x11 | ^Q | Device control 1 (XON) |
|
||||
| 'r' | 0o22 | 18 | DC2 | 0x12 | ^R | Device control 2 |
|
||||
| 's' | 0o23 | 19 | DC3 | 0x13 | ^S | Device control 3 (XOFF) |
|
||||
| 't' | 0o24 | 20 | DC4 | 0x14 | ^T | Device control 4 |
|
||||
| 'u' | 0o25 | 21 | NAK | 0x15 | ^U | Negative acknowledge |
|
||||
| 'v' | 0o26 | 22 | SYN | 0x16 | ^V | Synchronous idle |
|
||||
| 'w' | 0o27 | 23 | ETB | 0x17 | ^W | End of transmission block |
|
||||
| 'x' | 0o30 | 24 | CAN | 0x18 | ^X | Cancel |
|
||||
| 'y' | 0o31 | 25 | EM | 0x19 | ^Y | End of medium |
|
||||
| 'z' | 0o32 | 26 | SUB | 0x1a | ^Z | Substitute character |
|
||||
| '[' | 0o33 | 27 | ESC | 0x1b | ^[ | Escape |
|
||||
| '\' | 0o34 | 28 | FS | 0x1c | ^\ | File separator, Information separator four |
|
||||
| ']' | 0o35 | 29 | GS | 0x1d | ^] | Group separator, Information separator three |
|
||||
| '^' | 0o36 | 30 | RS | 0x1e | ^^ | Record separator, Information separator two |
|
||||
| '_' | 0o37 | 31 | US | 0x1f | ^_ | Unit separator, Information separator one |
|
||||
| '?' | 0o177 | 127 | DEL | 0x7f | ^? | Delete |
|
||||
+------+-------+------+------+------+-------+------------------------------------------------+
|
||||
]}
|
||||
*)
|
||||
|
||||
val key_enter : key
|
||||
(** [key_enter = Key_control 'j'] *)
|
||||
|
||||
val key_escape : key
|
||||
(** [key_escape = Key_control '\['] *)
|
||||
|
||||
val key_tab : key
|
||||
(** [key_escape = Key_control 'i'] *)
|
||||
|
||||
val key_backspace : key
|
||||
(** [key_backspace = Key_control '?'] *)
|
||||
|
||||
val sequence_mapping : (Text.t * key) list
|
||||
(** Mapping from sequence to keys *)
|
||||
|
||||
val decode_key : Text.t -> key
|
||||
(** Decode a key. *)
|
||||
|
||||
val standard_input : Text.t Lwt_stream.t
|
||||
(** The input stream used by {!read_key} *)
|
||||
|
||||
val read_key : unit -> key Lwt.t
|
||||
(** Get and decode a key from {!standard_input} *)
|
||||
|
||||
(** {6 Styles} *)
|
||||
|
||||
type color = int
|
||||
(** Type of a color. Most modern terminals support either 88 or
|
||||
256 colors. *)
|
||||
|
||||
val set_color : color -> int * int * int -> unit Lwt.t
|
||||
(** [set_color num (red, green, blue)] sets the three components of
|
||||
the color number [num] *)
|
||||
|
||||
(** {8 Standard colors} *)
|
||||
|
||||
val default : color
|
||||
val black : color
|
||||
val red : color
|
||||
val green : color
|
||||
val yellow : color
|
||||
val blue : color
|
||||
val magenta : color
|
||||
val cyan : color
|
||||
val white : color
|
||||
|
||||
(** {8 Light colors} *)
|
||||
|
||||
(** Note: these colors are not supposed to works on all terminals, but
|
||||
in practice it works with all modern ones. By the way, using
|
||||
standard colors + bold mode will give the same result as using a
|
||||
light color. *)
|
||||
|
||||
val lblack : color
|
||||
val lred : color
|
||||
val lgreen : color
|
||||
val lyellow : color
|
||||
val lblue : color
|
||||
val lmagenta : color
|
||||
val lcyan : color
|
||||
val lwhite : color
|
||||
|
||||
(** {8 Text with styles} *)
|
||||
|
||||
(** Elmement of a styled-text *)
|
||||
type styled_text_instruction =
|
||||
| Text of Text.t
|
||||
(** Some text *)
|
||||
| Reset
|
||||
(** Resets all styles to default *)
|
||||
| Bold
|
||||
| Underlined
|
||||
| Blink
|
||||
| Inverse
|
||||
| Hidden
|
||||
| Foreground of color
|
||||
| Background of color
|
||||
|
||||
type styled_text = styled_text_instruction list
|
||||
(** A styled text is a list of instructions *)
|
||||
|
||||
val textf : ('a, unit, string, styled_text_instruction) format4 -> 'a
|
||||
(** [textf fmt] formats a texts with [fmt] and returns [Text txt] *)
|
||||
|
||||
val text : Text.t -> styled_text_instruction
|
||||
val reset : styled_text_instruction
|
||||
val bold : styled_text_instruction
|
||||
val underlined : styled_text_instruction
|
||||
val blink : styled_text_instruction
|
||||
val inverse : styled_text_instruction
|
||||
val hidden : styled_text_instruction
|
||||
|
||||
val fg : color -> styled_text_instruction
|
||||
(** [fg col = Foreground col] *)
|
||||
|
||||
val bg : color -> styled_text_instruction
|
||||
(** [bg col = Background col] *)
|
||||
|
||||
val strip_styles : styled_text -> Text.t
|
||||
(** Drop all styles *)
|
||||
|
||||
val styled_length : styled_text -> int
|
||||
(** Returns the length (in unicode character) of the given styled
|
||||
text. The following equality holds for all styled-texts:
|
||||
|
||||
[styled_length st = Text.length (strip_styles st)]
|
||||
*)
|
||||
|
||||
val write_styled : Lwt_text.output_channel -> styled_text -> unit Lwt.t
|
||||
(** [write_styled oc st] writes [st] on [oc] using escape
|
||||
sequences. *)
|
||||
|
||||
val printc : styled_text -> unit Lwt.t
|
||||
(** [printc st] prints the given styled text on standard output. If
|
||||
stdout is not a tty, then styles are stripped.
|
||||
|
||||
The text is encoded to the system encoding before being
|
||||
output. *)
|
||||
|
||||
val eprintc : styled_text -> unit Lwt.t
|
||||
(** Same as [printc] but prints on stderr. *)
|
||||
|
||||
val printlc : styled_text -> unit Lwt.t
|
||||
(** [printlc st] prints [st], then reset styles and prints a
|
||||
newline *)
|
||||
|
||||
val eprintlc : styled_text -> unit Lwt.t
|
||||
(** Same as [printlc] but prints on stderr *)
|
||||
|
||||
(** {6 Rendering} *)
|
||||
|
||||
(** Character styles *)
|
||||
type style = {
|
||||
bold : bool;
|
||||
underlined : bool;
|
||||
blink : bool;
|
||||
inverse : bool;
|
||||
hidden : bool;
|
||||
foreground : color;
|
||||
background : color;
|
||||
}
|
||||
|
||||
(** A character on the screen: *)
|
||||
type point = {
|
||||
char : Text.t;
|
||||
(** The character. *)
|
||||
style : style;
|
||||
(** The character style *)
|
||||
}
|
||||
|
||||
val blank : point
|
||||
(** A space with default color and styles *)
|
||||
|
||||
val render : point array array -> unit Lwt.t
|
||||
(** Render an offscreen array to the terminal. *)
|
||||
|
||||
val render_update : point array array -> point array array -> unit Lwt.t
|
||||
(** [render_update displayed to_display] does the same as [render
|
||||
to_display] but assumes that [displayed] contains the current
|
||||
displayed text. This reduces the amount of text sent to the
|
||||
terminal. *)
|
||||
|
||||
(** {6 Drawing} *)
|
||||
|
||||
(** Off-screen zones *)
|
||||
module Zone : sig
|
||||
type t = {
|
||||
points : point array array;
|
||||
(** The off-screen matrix *)
|
||||
|
||||
x : int;
|
||||
y : int;
|
||||
(** Absolute coordinates of the top-left corner of the zone *)
|
||||
|
||||
width : int;
|
||||
height : int;
|
||||
(** Dimmensions of the zone *)
|
||||
}
|
||||
|
||||
val points : t -> point array array
|
||||
val x : t -> int
|
||||
val y : t -> int
|
||||
val width : t -> int
|
||||
val height : t -> int
|
||||
|
||||
val make : width : int -> height : int -> t
|
||||
(** Make a new zone where all points are initialized to
|
||||
{!blank} *)
|
||||
|
||||
val sub : zone : t -> x : int -> y : int -> width : int -> height : int -> t
|
||||
(** [sub ~zone ~x ~y ~width ~height] creates a sub-zone of
|
||||
[zone]. [x] and [y] are relatives to the zone top left corner.
|
||||
|
||||
@raise Invalid_argument if the sub zone is not included in
|
||||
[zone]*)
|
||||
|
||||
val inner : t -> t
|
||||
(** [inner zone] returns the inner part of [zone] *)
|
||||
end
|
||||
|
||||
(** Drawing helpers *)
|
||||
module Draw : sig
|
||||
|
||||
(** Note: except for {!get}, all function ignore points that are
|
||||
outside the zone *)
|
||||
|
||||
val get : zone : Zone.t -> x : int -> y : int -> point
|
||||
(** [get ~zone ~x ~y] returns the point at relative position [x]
|
||||
and [y].
|
||||
|
||||
@raise Invalid_argument if the coordinates are outside the
|
||||
zone *)
|
||||
|
||||
val set : zone : Zone.t -> x : int -> y : int -> point : point -> unit
|
||||
(** [set ~zone ~x ~y ~popint] sets point at relative position [x]
|
||||
and [y]. *)
|
||||
|
||||
val map : zone : Zone.t -> x : int -> y : int -> (point -> point) -> unit
|
||||
(** [map ~zone ~x ~y f] replace the point at coordinates [(x, y)]
|
||||
by the result of [f] applied on it. *)
|
||||
|
||||
val text : zone : Zone.t -> x : int -> y : int -> text : Text.t -> unit
|
||||
(** Draw the given text at the given positon *)
|
||||
|
||||
val textf : Zone.t -> int -> int -> ('a, unit, string, unit) format4 -> 'a
|
||||
(** Same as {!text} but uses a format string *)
|
||||
|
||||
val textc : zone : Zone.t -> x : int -> y : int -> text : styled_text -> unit
|
||||
(** Same as {!text} but takes a text with styles *)
|
||||
end
|
|
@ -0,0 +1,337 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Interface Lwt_text
|
||||
* Copyright (C) 2009 Jérémie Dimino
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
open Lwt
|
||||
open Lwt_io
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Types and creation |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
type coder =
|
||||
| Encoder of Encoding.encoder
|
||||
| Decoder of Encoding.decoder
|
||||
|
||||
type 'a channel = {
|
||||
channel : 'a Lwt_io.channel;
|
||||
encoding : Text.t;
|
||||
coder : coder;
|
||||
strict : bool;
|
||||
}
|
||||
|
||||
type input_channel = Lwt_io.input channel
|
||||
type output_channel = Lwt_io.output channel
|
||||
|
||||
let encoder = function
|
||||
| Encoder e -> e
|
||||
| Decoder _ -> assert false
|
||||
|
||||
let decoder = function
|
||||
| Encoder _ -> assert false
|
||||
| Decoder d -> d
|
||||
|
||||
#if ocaml_version >= (3, 13)
|
||||
let make : type m. ?strict : bool -> ?encoding : string -> m Lwt_io.channel -> m channel = fun ?(strict=false) ?(encoding=Encoding.system) ch ->
|
||||
#else
|
||||
let make ?(strict=false) ?(encoding=Encoding.system) ch =
|
||||
#endif
|
||||
{ channel = ch;
|
||||
encoding = encoding;
|
||||
strict = strict;
|
||||
coder = match Lwt_io.mode ch with
|
||||
| Input ->
|
||||
Decoder(Encoding.decoder encoding)
|
||||
| Output ->
|
||||
Encoder(Encoding.encoder(if strict then encoding else encoding ^ "//TRANSLIT")) }
|
||||
|
||||
let byte_channel ch = ch.channel
|
||||
let encoding ch = ch.encoding
|
||||
|
||||
let close ch = Lwt_io.close ch.channel
|
||||
let flush ch = Lwt_io.flush ch.channel
|
||||
|
||||
let atomic f ch = Lwt_io.atomic (fun ch' -> f { ch with channel = ch' }) ch.channel
|
||||
|
||||
let open_file ?buffer_size ?strict ?encoding ?flags ?perm ~mode name =
|
||||
lwt ch = Lwt_io.open_file ?flags ?perm ~mode name in
|
||||
return (make ?strict ?encoding ch)
|
||||
|
||||
let with_file ?buffer_size ?strict ?encoding ?flags ?perm ~mode name f =
|
||||
Lwt_io.with_file ?flags ?perm ~mode name (fun ch -> f (make ?strict ?encoding ch))
|
||||
|
||||
module Primitives =
|
||||
struct
|
||||
(* +---------------------------------------------------------------+
|
||||
| Primitives for reading |
|
||||
+---------------------------------------------------------------+ *)
|
||||
|
||||
let rec read_char da strict decoder =
|
||||
let ptr = da.da_ptr and max = da.da_max in
|
||||
if ptr = max then
|
||||
da.da_perform () >>= function
|
||||
| 0 -> raise_lwt End_of_file
|
||||
| _ -> read_char da strict decoder
|
||||
else
|
||||
match Encoding_bigarray.decode decoder da.da_buffer ptr (max - ptr) with
|
||||
| Encoding.Dec_ok(code, count) ->
|
||||
da.da_ptr <- ptr + count;
|
||||
return (Text.char code)
|
||||
| Encoding.Dec_need_more ->
|
||||
da.da_perform () >>= begin function
|
||||
| 0 ->
|
||||
if strict then
|
||||
raise_lwt (Failure "Lwt_text.read_char: unterminated multibyte sequence")
|
||||
else begin
|
||||
da.da_ptr <- ptr + 1;
|
||||
return (Text.char (Char.code da.da_buffer.{ptr}))
|
||||
end
|
||||
| _ ->
|
||||
read_char da strict decoder
|
||||
end
|
||||
| Encoding.Dec_error ->
|
||||
if strict then
|
||||
raise_lwt (Failure "Lwt_text.read_char: unterminated multibyte sequence")
|
||||
else begin
|
||||
da.da_ptr <- ptr + 1;
|
||||
return (Text.char (Char.code da.da_buffer.{ptr}))
|
||||
end
|
||||
|
||||
let read_char_opt da strict decoder =
|
||||
try_lwt
|
||||
read_char da strict decoder >|= fun ch -> Some ch
|
||||
with
|
||||
| End_of_file ->
|
||||
return None
|
||||
| exn ->
|
||||
raise_lwt exn
|
||||
|
||||
let rec read_all da strict decoder buf =
|
||||
lwt ch = read_char da strict decoder in
|
||||
Buffer.add_string buf ch;
|
||||
read_all da strict decoder buf
|
||||
|
||||
let rec read_count da strict decoder buf = function
|
||||
| 0 ->
|
||||
return (Buffer.contents buf)
|
||||
| n ->
|
||||
lwt ch = read_char da strict decoder in
|
||||
Buffer.add_string buf ch;
|
||||
read_count da strict decoder buf (n - 1)
|
||||
|
||||
let read count da strict decoder = match count with
|
||||
| None ->
|
||||
let buf = Buffer.create 512 in
|
||||
begin
|
||||
try_lwt
|
||||
read_all da strict decoder buf
|
||||
with
|
||||
| End_of_file ->
|
||||
return (Buffer.contents buf)
|
||||
end
|
||||
| Some 0 ->
|
||||
return ""
|
||||
| Some 1 ->
|
||||
begin
|
||||
try_lwt
|
||||
read_char da strict decoder
|
||||
with
|
||||
| End_of_file ->
|
||||
return ""
|
||||
end
|
||||
| Some len ->
|
||||
let buf = Buffer.create len in
|
||||
begin
|
||||
try_lwt
|
||||
read_count da strict decoder buf len
|
||||
with
|
||||
| End_of_file ->
|
||||
return (Buffer.contents buf)
|
||||
end
|
||||
|
||||
let read_line da strict decoder =
|
||||
let buf = Buffer.create 128 in
|
||||
let rec loop cr_read =
|
||||
try_bind (fun _ -> read_char da strict decoder)
|
||||
(function
|
||||
| "\n" ->
|
||||
return(Buffer.contents buf)
|
||||
| "\r" ->
|
||||
if cr_read then Buffer.add_char buf '\r';
|
||||
loop true
|
||||
| ch ->
|
||||
if cr_read then Buffer.add_char buf '\r';
|
||||
Buffer.add_string buf ch;
|
||||
loop false)
|
||||
(function
|
||||
| End_of_file ->
|
||||
if cr_read then Buffer.add_char buf '\r';
|
||||
return(Buffer.contents buf)
|
||||
| exn ->
|
||||
raise_lwt exn)
|
||||
in
|
||||
read_char da strict decoder >>= function
|
||||
| "\r" -> loop true
|
||||
| "\n" -> return ""
|
||||
| ch -> Buffer.add_string buf ch; loop false
|
||||
|
||||
let read_line_opt da strict decoder =
|
||||
try_lwt
|
||||
read_line da strict decoder >|= fun ch -> Some ch
|
||||
with
|
||||
| End_of_file ->
|
||||
return None
|
||||
| exn ->
|
||||
raise_lwt exn
|
||||
|
||||
(* +---------------------------------------------------------------+
|
||||
| Primitives for writing |
|
||||
+---------------------------------------------------------------+ *)
|
||||
|
||||
let rec write_code da encoder code =
|
||||
match Encoding_bigarray.encode encoder da.da_buffer da.da_ptr (da.da_max - da.da_ptr) code with
|
||||
| Encoding.Enc_ok count ->
|
||||
da.da_ptr <- da.da_ptr + count;
|
||||
return ()
|
||||
| Encoding.Enc_need_more ->
|
||||
lwt _ = da.da_perform () in
|
||||
write_code da encoder code
|
||||
| Encoding.Enc_error ->
|
||||
raise_lwt (Failure "Lwt_text: cannot encode character")
|
||||
|
||||
let byte str pos = Char.code (String.unsafe_get str pos)
|
||||
|
||||
let next_code str i len =
|
||||
let n = byte str i in
|
||||
let rec trail j acc = function
|
||||
| 0 ->
|
||||
(j, acc)
|
||||
| count ->
|
||||
if j = len then
|
||||
(i + 1, n)
|
||||
else
|
||||
let m = byte str j in
|
||||
if m land 0xc0 = 0x80 then
|
||||
trail (j + 1) ((acc lsl 6) lor (m land 0x3f)) (count - 1)
|
||||
else
|
||||
(i + 1, n)
|
||||
in
|
||||
if n land 0x80 = 0 then
|
||||
(i + 1, n)
|
||||
else if n land 0xe0 = 0xc0 then
|
||||
trail (i + 1) (n land 0x1f) 1
|
||||
else if n land 0xf0 = 0xe0 then
|
||||
trail (i + 1) (n land 0x0f) 2
|
||||
else if n land 0xf8 = 0xf0 then
|
||||
trail (i + 1) (n land 0x07) 3
|
||||
else
|
||||
(i + 1, n)
|
||||
|
||||
let write_char da strict encoder = function
|
||||
| "" ->
|
||||
raise_lwt (Invalid_argument "Lwt_text.write_char: empty text")
|
||||
| ch ->
|
||||
let _, code = next_code ch 0 (String.length ch) in
|
||||
write_code da encoder code
|
||||
|
||||
let rec write_all da strict encoder str i len =
|
||||
if i = len then
|
||||
return ()
|
||||
else
|
||||
let i, code = next_code str i len in
|
||||
lwt () = write_code da encoder code in
|
||||
write_all da strict encoder str i len
|
||||
|
||||
let write da strict encoder txt =
|
||||
write_all da strict encoder txt 0 (String.length txt)
|
||||
|
||||
let write_line da strict encoder txt =
|
||||
lwt () = write_all da strict encoder txt 0 (String.length txt) in
|
||||
write_code da encoder 10
|
||||
end
|
||||
|
||||
let read_char ic = direct_access ic.channel (fun da -> Primitives.read_char da ic.strict (decoder ic.coder))
|
||||
let read_char_opt ic = direct_access ic.channel (fun da -> Primitives.read_char_opt da ic.strict (decoder ic.coder))
|
||||
let read ?count ic = direct_access ic.channel (fun da -> Primitives.read count da ic.strict (decoder ic.coder))
|
||||
let read_line ic = direct_access ic.channel (fun da -> Primitives.read_line da ic.strict (decoder ic.coder))
|
||||
let read_line_opt ic = direct_access ic.channel (fun da -> Primitives.read_line_opt da ic.strict (decoder ic.coder))
|
||||
let read_chars ic = Lwt_stream.from (fun _ -> read_char_opt ic)
|
||||
let read_lines ic = Lwt_stream.from (fun _ -> read_line_opt ic)
|
||||
|
||||
let write_char oc x = direct_access oc.channel (fun da -> Primitives.write_char da oc.strict (encoder oc.coder) x)
|
||||
let write_line oc x = direct_access oc.channel (fun da -> Primitives.write_line da oc.strict (encoder oc.coder) x)
|
||||
let write oc x = direct_access oc.channel (fun da -> Primitives.write da oc.strict (encoder oc.coder) x)
|
||||
let write_chars oc st = Lwt_stream.iter_s (write_char oc) st
|
||||
let write_lines oc st = Lwt_stream.iter_s (write_line oc) st
|
||||
|
||||
let stdin = make Lwt_io.stdin
|
||||
let stdout = make Lwt_io.stdout
|
||||
let stderr = make Lwt_io.stderr
|
||||
let null = make Lwt_io.null
|
||||
let zero = make Lwt_io.zero
|
||||
|
||||
let fprint oc txt = write oc txt
|
||||
let fprintl oc txt = write_line oc txt
|
||||
let fprintf oc fmt = Printf.ksprintf (fun txt -> write oc txt) fmt
|
||||
let fprintlf oc fmt = Printf.ksprintf (fun txt -> write_line oc txt) fmt
|
||||
|
||||
let print txt = write stdout txt
|
||||
let printl txt = write_line stdout txt
|
||||
let printf fmt = Printf.ksprintf print fmt
|
||||
let printlf fmt = Printf.ksprintf printl fmt
|
||||
|
||||
let eprint txt = write stderr txt
|
||||
let eprintl txt = write_line stderr txt
|
||||
let eprintf fmt = Printf.ksprintf eprint fmt
|
||||
let eprintlf fmt = Printf.ksprintf eprintl fmt
|
||||
|
||||
let ignore_close ch =
|
||||
ignore (close ch)
|
||||
|
||||
let make_stream f lazy_ic =
|
||||
let lazy_ic =
|
||||
lazy(lwt ic = Lazy.force lazy_ic in
|
||||
Gc.finalise ignore_close ic;
|
||||
return ic)
|
||||
in
|
||||
Lwt_stream.from (fun _ ->
|
||||
lwt ic = Lazy.force lazy_ic in
|
||||
try_lwt
|
||||
f ic >|= fun x -> Some x
|
||||
with
|
||||
| End_of_file ->
|
||||
lwt () = close ic in
|
||||
return None)
|
||||
|
||||
let lines_of_file filename =
|
||||
make_stream read_line (lazy(open_file ~mode:input filename))
|
||||
|
||||
let lines_to_file filename lines =
|
||||
with_file ~mode:output filename (fun oc -> write_lines oc lines)
|
||||
|
||||
let chars_of_file filename =
|
||||
make_stream read_char (lazy(open_file ~mode:input filename))
|
||||
|
||||
let chars_to_file filename chars =
|
||||
with_file ~mode:output filename (fun oc -> write_chars oc chars)
|
||||
|
||||
let hexdump_stream oc stream = write_lines oc (Lwt_stream.hexdump stream)
|
||||
let hexdump oc buf = hexdump_stream oc (Lwt_stream.of_string buf)
|
|
@ -0,0 +1,128 @@
|
|||
(* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Interface Lwt_text
|
||||
* Copyright (C) 2009 Jérémie Dimino
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*)
|
||||
|
||||
(** Text channels *)
|
||||
|
||||
(** This modules implements {b text channel}s. A {b text channel} is
|
||||
basically a {b byte channel} (as in {!Lwt_io}) plus a {b character
|
||||
encoding}.
|
||||
|
||||
It has almost the same interface as {!Lwt_io} except that it
|
||||
uses [Text.t] in place of [string] and [char]
|
||||
*)
|
||||
|
||||
open Lwt_io
|
||||
|
||||
(** {6 Types} *)
|
||||
|
||||
type 'mode channel
|
||||
(** Type of a text channel *)
|
||||
|
||||
type input_channel = input channel
|
||||
(** Type of a text input channel *)
|
||||
|
||||
type output_channel = output channel
|
||||
(** Type of a text output channel *)
|
||||
|
||||
(** {6 Creation/manipulation} *)
|
||||
|
||||
val make : ?strict : bool -> ?encoding : Encoding.t -> 'a Lwt_io.channel -> 'a channel
|
||||
(** [make ?strict ?encoding ch] creates a text channel from a byte
|
||||
channel.
|
||||
|
||||
@param strict tell whether encoding/decoding must be ``strict'',
|
||||
which whether the encoder/decoder should fail on invalid
|
||||
sequence. In non-strict mode, it transparently fallback to
|
||||
ISO-8859-15. By the way it is ensured that [read*] functions
|
||||
always returns valid UTF-8 encoded text. [strict] defaults to
|
||||
[false].
|
||||
|
||||
@param encoding is the character encoding used for the
|
||||
channel. It defaults to [Encoding.system]. *)
|
||||
|
||||
val byte_channel : 'a channel -> 'a Lwt_io.channel
|
||||
(** [byte_channel ch] returns the underlying byte channel of a text
|
||||
channel *)
|
||||
|
||||
val encoding : 'a channel -> Encoding.t
|
||||
(** [encoding ch] returns the character encoding of a channel. *)
|
||||
|
||||
val flush : output_channel -> unit Lwt.t
|
||||
(** Flush the underlying byte channel *)
|
||||
|
||||
val close : 'a channel -> unit Lwt.t
|
||||
(** Close the underlying byte channel *)
|
||||
|
||||
(** {6 Lwt_io like values} *)
|
||||
|
||||
val atomic : ('a channel -> 'b Lwt.t) -> ('a channel -> 'b Lwt.t)
|
||||
val stdin : input_channel
|
||||
val stdout : output_channel
|
||||
val stderr : output_channel
|
||||
val zero : input_channel
|
||||
val null : output_channel
|
||||
val read_char : input_channel -> Text.t Lwt.t
|
||||
val read_char_opt : input_channel -> Text.t option Lwt.t
|
||||
val read_chars : input_channel -> Text.t Lwt_stream.t
|
||||
val read_line : input_channel -> Text.t Lwt.t
|
||||
val read_line_opt : input_channel -> Text.t option Lwt.t
|
||||
val read_lines : input_channel -> Text.t Lwt_stream.t
|
||||
val read : ?count : int -> input_channel -> Text.t Lwt.t
|
||||
val write_char : output_channel -> Text.t -> unit Lwt.t
|
||||
val write_chars : output_channel -> Text.t Lwt_stream.t -> unit Lwt.t
|
||||
val write : output_channel -> Text.t -> unit Lwt.t
|
||||
val write_line : output_channel -> Text.t -> unit Lwt.t
|
||||
val write_lines : output_channel -> Text.t Lwt_stream.t -> unit Lwt.t
|
||||
val open_file :
|
||||
?buffer_size : int ->
|
||||
?strict : bool ->
|
||||
?encoding : Encoding.t ->
|
||||
?flags : Unix.open_flag list ->
|
||||
?perm : Unix.file_perm ->
|
||||
mode : 'a mode ->
|
||||
file_name -> 'a channel Lwt.t
|
||||
val with_file :
|
||||
?buffer_size : int ->
|
||||
?strict : bool ->
|
||||
?encoding : Encoding.t ->
|
||||
?flags : Unix.open_flag list ->
|
||||
?perm : Unix.file_perm ->
|
||||
mode : 'a mode ->
|
||||
file_name -> ('a channel -> 'b Lwt.t) -> 'b Lwt.t
|
||||
val lines_of_file : file_name -> Text.t Lwt_stream.t
|
||||
val lines_to_file : file_name -> Text.t Lwt_stream.t -> unit Lwt.t
|
||||
val chars_of_file : file_name -> Text.t Lwt_stream.t
|
||||
val chars_to_file : file_name -> Text.t Lwt_stream.t -> unit Lwt.t
|
||||
val fprint : output_channel -> Text.t -> unit Lwt.t
|
||||
val fprintl : output_channel -> Text.t -> unit Lwt.t
|
||||
val fprintf : output_channel -> ('a, unit, Text.t, unit Lwt.t) format4 -> 'a
|
||||
val fprintlf : output_channel -> ('a, unit, Text.t, unit Lwt.t) format4 -> 'a
|
||||
val print : Text.t -> unit Lwt.t
|
||||
val printl : Text.t -> unit Lwt.t
|
||||
val printf : ('a, unit, Text.t, unit Lwt.t) format4 -> 'a
|
||||
val printlf : ('a, unit, Text.t, unit Lwt.t) format4 -> 'a
|
||||
val eprint : Text.t -> unit Lwt.t
|
||||
val eprintl : Text.t -> unit Lwt.t
|
||||
val eprintf : ('a, unit, Text.t, unit Lwt.t) format4 -> 'a
|
||||
val eprintlf : ('a, unit, Text.t, unit Lwt.t) format4 -> 'a
|
||||
val hexdump_stream : output_channel -> char Lwt_stream.t -> unit Lwt.t
|
||||
val hexdump : output_channel -> string -> unit Lwt.t
|
|
@ -0,0 +1,84 @@
|
|||
/* Lightweight thread library for Objective Caml
|
||||
* http://www.ocsigen.org/lwt
|
||||
* Module Lwt_text_stubs
|
||||
* Copyright (C) 2011 Jérémie Dimino
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as
|
||||
* published by the Free Software Foundation, with linking exceptions;
|
||||
* either version 2.1 of the License, or (at your option) any later
|
||||
* version. See COPYING file for details.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public
|
||||
* License along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
||||
* 02111-1307, USA.
|
||||
*/
|
||||
|
||||
#if defined(_WIN32) || defined(_WIN64)
|
||||
# include <windows.h>
|
||||
# include <wincon.h>
|
||||
#else
|
||||
# include <sys/ioctl.h>
|
||||
# include <termios.h>
|
||||
# include <errno.h>
|
||||
# include <signal.h>
|
||||
#endif
|
||||
|
||||
#include "../unix/lwt_unix.h"
|
||||
|
||||
#include <caml/alloc.h>
|
||||
#include <caml/fail.h>
|
||||
|
||||
/* +-----------------------------------------------------------------+
|
||||
| Terminal sizes |
|
||||
+-----------------------------------------------------------------+ */
|
||||
|
||||
#if defined(LWT_ON_WINDOWS)
|
||||
|
||||
CAMLprim value lwt_text_term_size(value fd)
|
||||
{
|
||||
HANDLE handle;
|
||||
CONSOLE_SCREEN_BUFFER_INFO info;
|
||||
|
||||
if (!GetConsoleScreenBufferInfo(Handle_val(fd), &info)) {
|
||||
win32_maperr(GetLastError());
|
||||
uerror("GetConsoleScreenBufferInfo", Nothing);
|
||||
}
|
||||
|
||||
value result = caml_alloc_tuple(2);
|
||||
Field(result, 0) = Val_int(info.dwSize.X);
|
||||
Field(result, 1) = Val_int(info.dwSize.Y);
|
||||
return result;
|
||||
}
|
||||
|
||||
#else
|
||||
|
||||
CAMLprim value lwt_text_term_size(value fd)
|
||||
{
|
||||
struct winsize size;
|
||||
|
||||
if (ioctl(Int_val(fd), TIOCGWINSZ, &size) < 0)
|
||||
uerror("ioctl", Nothing);
|
||||
|
||||
value result = caml_alloc_tuple(2);
|
||||
Field(result, 0) = Val_int(size.ws_row);
|
||||
Field(result, 1) = Val_int(size.ws_col);
|
||||
return result;
|
||||
}
|
||||
|
||||
CAMLprim value lwt_text_sigwinch()
|
||||
{
|
||||
#ifdef SIGWINCH
|
||||
return Val_int(SIGWINCH);
|
||||
#else
|
||||
return Val_int(0);
|
||||
#endif
|
||||
}
|
||||
|
||||
#endif
|
|
@ -0,0 +1,5 @@
|
|||
# OASIS_START
|
||||
# DO NOT EDIT (digest: 6aba40695d6f4091d2063c4b620ae589)
|
||||
Lwt_top
|
||||
Lwt_ocaml_completion
|
||||
# OASIS_STOP
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue