Commit b3dca643 authored by Louis Gesbert's avatar Louis Gesbert
Browse files

Prototype stdin handling

parent 4bf99526
......@@ -709,8 +709,8 @@ let create_toplevel =
let get_worker = get_worker_code "learnocaml-toplevel-worker.js" in
fun
?display_welcome ?on_disable_input ?on_enable_input ?history ?after_init
~timeout_prompt ~flood_prompt ~container () ->
~stdin_prompt ~timeout_prompt ~flood_prompt ~container () ->
get_worker () >>= fun worker_js_file ->
Learnocaml_toplevel.create ~worker_js_file
Learnocaml_toplevel.create ~worker_js_file ~stdin_prompt
?display_welcome ?on_disable_input ?on_enable_input ?history ?after_init
~timeout_prompt ~flood_prompt ~container ()
......@@ -172,6 +172,7 @@ val create_toplevel:
?on_enable_input:(Learnocaml_toplevel.t -> unit) ->
?history:Learnocaml_toplevel_history.history ->
?after_init:(Learnocaml_toplevel.t -> unit Lwt.t) ->
stdin_prompt:(Learnocaml_toplevel.t -> unit -> string Lwt.t) ->
timeout_prompt:(Learnocaml_toplevel.t -> unit Lwt.t) ->
flood_prompt: (Learnocaml_toplevel.t -> string -> (unit -> int) -> bool Lwt.t) ->
container:[`Div] Tyxml_js.Html5.elt ->
......
......@@ -178,6 +178,10 @@ let () =
let after_init top =
Learnocaml_toplevel.set_checking_environment top
in
let stdin_prompt t () =
Learnocaml_toplevel.make_stdin_popup
~on_show: (fun () -> select_tab Ids.toplevel_pane)
() t in
let timeout_prompt =
Learnocaml_toplevel.make_timeout_popup
~on_show: (fun () -> select_tab Ids.toplevel_pane)
......@@ -202,7 +206,7 @@ let () =
~snapshot () in
let toplevel_launch =
create_toplevel
~after_init ~timeout_prompt ~flood_prompt
~after_init ~stdin_prompt ~timeout_prompt ~flood_prompt
~on_disable_input: (fun _ -> disable_button_group toplevel_buttons_group)
~on_enable_input: (fun _ -> enable_button_group toplevel_buttons_group)
~container:toplevel_pane
......
......@@ -362,6 +362,34 @@ let make_flood_popup
Manip.removeChild container dialog ;
Lwt.fail exn)
let make_stdin_popup
?(on_show = (fun () -> ()))
() { container; _ } =
let open Tyxml_js.Html5 in
let input_id = "stdin-popup-in" in
let btn_ok =
button [ txt [%i"Ok"] ] in
let dialog =
div ~a: [ a_class [ "dialog-container" ] ]
[ div ~a: [ a_class [ "dialog" ] ]
[ h1 [ txt [%i"Input requested"] ] ;
div ~a: [ a_class [ "message" ] ]
[ Tyxml_js.Html5.input ~a: [ a_id input_id ] () ];
div ~a: [ a_class [ "buttons" ] ] [ btn_ok ] ] ] in
let t, u = Lwt.task () in
Manip.Ev.onclick btn_ok
(fun _ ->
let s =
match Manip.by_id input_id
with Some e -> Manip.value e | None -> ""
in
Manip.removeChild container dialog;
Lwt.wakeup u s;
true);
Manip.appendChild container dialog ;
on_show () ;
t
let wrap_flusher_to_prevent_flood top name hook real =
let flooded = ref 0 in
hook := fun s ->
......@@ -405,6 +433,7 @@ let welcome_phrase () =
let create
?worker_js_file
~stdin_prompt
?(timeout_delay = 5.)
~timeout_prompt
?(flood_limit = 8000)
......@@ -439,6 +468,8 @@ let create
?on_resize
?history
() in
let pp_stdin_hook = ref (fun () -> Lwt.return "") in
let pp_stdin () = !pp_stdin_hook () in
let pp_stdout_hook = ref ignore in
let pp_stdout s = !pp_stdout_hook s in
let pp_stderr_hook = ref ignore in
......@@ -451,10 +482,11 @@ let create
(Learnocaml_toplevel_output.output_stdout ~phrase output) ;
wrap_flusher_to_prevent_flood top
"stderr" pp_stderr_hook
(Learnocaml_toplevel_output.output_stderr ~phrase output) in
(Learnocaml_toplevel_output.output_stderr ~phrase output) ;
pp_stdin_hook := stdin_prompt top in
Learnocaml_toplevel_worker_caller.create
?js_file:worker_js_file
~pp_stdout ~pp_stderr () >>= fun worker ->
~pp_stdin ~pp_stdout ~pp_stderr () >>= fun worker ->
let top = {
timeout_prompt;
current_timeout_prompt = Lwt.return ();
......
......@@ -61,6 +61,7 @@ type t
is to be displayed or not. *)
val create:
?worker_js_file:string ->
stdin_prompt:(t -> unit -> string Lwt.t) ->
?timeout_delay: float ->
timeout_prompt:(t -> unit Lwt.t) ->
?flood_limit: int ->
......@@ -76,6 +77,13 @@ val create:
container:[`Div] Html5.elt ->
unit -> t Lwt.t
(** Creates a thread that displays a popup over the toplevel container
with an input field, to fulfill needs for program stdin *)
val make_stdin_popup:
?on_show: (unit -> unit) ->
unit ->
t -> string Lwt.t
(** Creates a thread that displays a popup over the toplevel container
with a countdown and a button to augment it manually, and
terminates after the countdown. *)
......
......@@ -56,6 +56,7 @@ type t = {
mutable fd_counter: int;
mutable reset_worker: t -> unit Lwt.t;
mutable after_init: t -> unit Lwt.t;
pp_stdin: unit -> string Lwt.t;
pp_stdout: string -> unit;
pp_stderr: string -> unit;
}
......@@ -159,7 +160,8 @@ and onmessage worker (ev : _ Worker.messageEvent Js.t) =
Js._false
end
| RequestInput ->
post worker (Send_input "toto");
Lwt.async (fun () -> worker.pp_stdin () >>= fun s ->
let _ = post worker (Send_input s) in Lwt.return_unit);
Js._false
| ReturnSuccess (id, ty_v, v, w) -> begin
if !debug then Js_utils.debug "Host: ReturnOk %d" id;
......@@ -195,6 +197,7 @@ and onmessage worker (ev : _ Worker.messageEvent Js.t) =
let create
?(js_file = "/js/learnocaml-toplevel-worker.js")
?(after_init = fun _ -> Lwt.return_unit)
?(pp_stdin = (fun () -> Lwt.return "foo"))
?(pp_stdout = (fun text -> Firebug.console##(log (Js.string text))))
?(pp_stderr = (fun text -> Firebug.console##(log (Js.string text))))
() =
......@@ -207,7 +210,7 @@ let create
{ worker; js_file;
wakeners = IntMap.empty; counter = 0; fds; fd_counter = 2;
reset_worker = do_reset_worker ();
after_init; pp_stdout; pp_stderr;
after_init; pp_stdin; pp_stdout; pp_stderr;
} in
(Obj.magic worker.worker)##.onmessage := Js.wrap_callback (onmessage worker);
post worker @@ Init >>= fun _ ->
......
......@@ -36,6 +36,7 @@ type t
val create:
?js_file: string ->
?after_init:(t -> unit Lwt.t) ->
?pp_stdin:(unit -> string Lwt.t) ->
?pp_stdout:(string -> unit) ->
?pp_stderr:(string -> unit) ->
unit -> t Lwt.t
......
......@@ -131,6 +131,49 @@ let make_answer_ppf fd_answer =
(** Code compilation and execution *)
let stdin: string Lwt.u Queue.t = Queue.create ()
let request_input: (string -> unit) -> unit = fun k ->
let t, u = Lwt.wait () in
Queue.push u stdin;
post_message RequestInput;
Lwt.async (fun () -> Lwt.map k t)
let register_request_input () =
let name = "request_input" in
let ty =
let ast =
let arg =
let arg =
Ast_helper.(Typ.constr (Location.mknoloc (Longident.Lident "string")) []) in
let ret =
Ast_helper.(Typ.constr (Location.mknoloc (Longident.Lident "unit")) []) in
{ Parsetree.ptyp_desc = Parsetree.Ptyp_arrow (Asttypes.Nolabel, arg, ret) ;
ptyp_loc = Location.none ;
ptyp_attributes = [];
ptyp_loc_stack = [] } in
let ret =
Ast_helper.(Typ.constr (Location.mknoloc (Longident.Lident "unit")) []) in
{ Parsetree.ptyp_desc = Parsetree.Ptyp_arrow (Asttypes.Nolabel, arg, ret) ;
ptyp_loc = Location.none ;
ptyp_attributes = [];
ptyp_loc_stack = [] } in
Typetexp.transl_type_scheme !Toploop.toplevel_env ast in
Toploop.toplevel_env :=
Env.add_value
(Ident.create_local name)
{ Types.
val_uid = Types.Uid.mk ~current_unit:"Learnocaml_input";
val_type = ty.Typedtree.ctyp_type;
val_kind = Types.Val_reg;
val_attributes = [];
val_loc = Location.none }
!Toploop.toplevel_env ;
Toploop.setvalue name (Obj.repr request_input)
let register_prims () =
register_request_input ()
(* TODO protect execution with a mutex! *)
(** Message dispatcher *)
......@@ -140,8 +183,6 @@ let iter_option f o = match o with | None -> () | Some o -> f o
let checking_environment = ref !Toploop.toplevel_env
let stdin: string Lwt.u Queue.t = Queue.create ()
let handler : type a. a host_msg -> a return Lwt.t = function
| Set_checking_environment ->
checking_environment := !Toploop.toplevel_env ;
......@@ -152,6 +193,7 @@ let handler : type a. a host_msg -> a return Lwt.t = function
if !debug then Js_utils.debug "Worker: -> Reset";
clear_fds ();
Toploop.initialize_toplevel_env ();
register_prims ();
if !debug then Js_utils.debug "Worker: <- Reset";
return_unit_success
| Execute (fd_code, print_outcome, fd_answer, code) ->
......@@ -226,12 +268,6 @@ let handler : type a. a host_msg -> a return Lwt.t = function
end;
return_unit_success
let request_input () =
let t, u = Lwt.wait () in
Queue.push u stdin;
post_message RequestInput;
t
let ty_of_host_msg : type t. t host_msg -> t msg_ty = function
| Init -> Unit
| Reset -> Unit
......@@ -279,35 +315,10 @@ let () =
| e ->
Js_utils.log "FAILED INIT %s" (Printexc.to_string e));
let _add_request_input =
let name = "request_input" in
let ty =
let ast =
let arg =
Ast_helper.(Typ.constr (Location.mknoloc (Longident.Lident "unit")) []) in
let ret =
Ast_helper.(Typ.constr (Location.mknoloc (Longident.Lident "string")) []) in
{ Parsetree.ptyp_desc = Parsetree.Ptyp_arrow (Asttypes.Nolabel, arg, ret) ;
ptyp_loc = Location.none ;
ptyp_attributes = [];
ptyp_loc_stack = [] } in
Typetexp.transl_type_scheme !Toploop.toplevel_env ast in
Toploop.toplevel_env :=
Env.add_value
(Ident.create_local name)
{ Types.
val_uid = Types.Uid.mk ~current_unit:"Learnocaml_input";
val_type = ty.Typedtree.ctyp_type;
val_kind = Types.Val_reg;
val_attributes = [];
val_loc = Location.none }
!Toploop.toplevel_env ;
Toploop.setvalue name (Obj.repr request_input)
in
Hashtbl.add Toploop.directive_table
"debug_worker"
(Toploop.Directive_bool (fun b -> debug := b));
register_prims ();
Worker.set_onmessage (fun s -> Lwt.async (fun () -> handler s))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment