diff --git a/src/lib/uTop.ml b/src/lib/uTop.ml index fcc2e58..d8b9eab 100644 --- a/src/lib/uTop.ml +++ b/src/lib/uTop.ml @@ -67,6 +67,7 @@ type syntax = let syntax, get_syntax, set_syntax = make_variable Normal let phrase_terminator, get_phrase_terminator, set_phrase_terminator = make_variable ";;" let auto_run_lwt, get_auto_run_lwt, set_auto_run_lwt = make_variable true +let auto_run_async, get_auto_run_async, set_auto_run_async = make_variable true (* +-----------------------------------------------------------------+ | Keywords | diff --git a/src/lib/uTop.mli b/src/lib/uTop.mli index f1f6533..6e6cac8 100644 --- a/src/lib/uTop.mli +++ b/src/lib/uTop.mli @@ -88,6 +88,28 @@ val get_auto_run_lwt : unit -> bool val set_auto_run_lwt : bool -> unit (** Modifies {!auto_run_lwt}. *) +val auto_run_async : bool signal + (** If [true] (the default) toplevel Async expressions are + automatically run with in a separate thread with + [Thread_safe.block_on_async_exn]. i.e. if you type: + + {[ + after (Time.Span.of_s 1.0) + ]} + + this will be replaced by: + + {[ + Thread_safe.block_on_async_exn (fun () -> after (Time.Span.of_s 1.0)) + ]} + *) + +val get_auto_run_async : unit -> bool + (** Returns the value of {!auto_run_async}. *) + +val set_auto_run_async : bool -> unit + (** Modifies {!auto_run_async}. *) + (** {6 History} *) val history : LTerm_history.t diff --git a/src/lib/uTop_main.ml b/src/lib/uTop_main.ml index df7f4bf..f1f8647 100644 --- a/src/lib/uTop_main.ml +++ b/src/lib/uTop_main.ml @@ -227,6 +227,8 @@ let with_loc loc str = str #endif let longident_lwt_main_run = Longident.Ldot (Longident.Lident "Lwt_main", "run") +let longident_async_main_run = Longident.parse "Async.Std.Thread_safe.block_on_async_exn" +let longident_unit = Longident.Lident "()" let is_eval = function | { Parsetree.pstr_desc = Parsetree.Pstr_eval _ } -> true @@ -241,6 +243,16 @@ let rec is_lwt_t typ = | _ -> false +let rec is_async_t typ = + match typ.Types.desc with + | Types.Tlink typ -> + is_async_t typ + | Types.Tconstr (path, _, _) -> + let n = Path.name path in + (n = "Async_core.Deferred.t") || (n = "Async.Std.Deferred.t") + | _ -> + false + #if ocaml_version >= (4, 0, 0) let str_items_of_typed_structure tstr = tstr.Typedtree.str_items let str_desc_of_typed_str_item tstr = tstr.Typedtree.str_desc @@ -292,6 +304,56 @@ let insert_lwt_main_run phrase = | Parsetree.Ptop_dir _ -> phrase +let insert_async_main_run phrase = + let wrap_unit loc e = + let open Parsetree in + let i = with_loc loc longident_unit in + let p = { ppat_desc = Ppat_construct (i, None, false); ppat_loc=loc } in + { pexp_desc=Pexp_function ("", None, [p,e]); pexp_loc=loc } in + match phrase with + | Parsetree.Ptop_def pstr -> + let env = !Toploop.toplevel_env in + let async_main_run_is_the_real_one = + try + let path, _ = Env.lookup_value longident_async_main_run env in + let rec is_persistent = function + | Path.Pident id -> Ident.persistent id + | Path.Pdot(t, _, _) -> is_persistent t + | Path.Papply(_, p) -> is_persistent p + in + is_persistent path + with Not_found -> + false + in + if async_main_run_is_the_real_one && List.exists is_eval pstr then + let tstr, _, _ = Typemod.type_structure env pstr Location.none in + let tstr = str_items_of_typed_structure tstr in + Parsetree.Ptop_def + (List.map2 + (fun pstr_item tstr_item -> + match pstr_item, str_desc_of_typed_str_item tstr_item with + | { Parsetree.pstr_desc = Parsetree.Pstr_eval e; Parsetree.pstr_loc = loc }, + Typedtree.Tstr_eval { Typedtree.exp_type = typ } when is_async_t typ -> + { + Parsetree.pstr_desc = + Parsetree.Pstr_eval { + Parsetree.pexp_desc = + Parsetree.Pexp_apply + ({ Parsetree.pexp_desc = Parsetree.Pexp_ident (with_loc loc longident_async_main_run); + Parsetree.pexp_loc = loc }, + [("", (wrap_unit loc e))]); + Parsetree.pexp_loc = loc; + }; + Parsetree.pstr_loc = loc; + } + | _ -> + pstr_item) + pstr tstr) + else + phrase + | Parsetree.Ptop_dir _ -> + phrase + (* +-----------------------------------------------------------------+ | Main loop | +-----------------------------------------------------------------+ *) @@ -345,6 +407,8 @@ let rec loop term = | Some phrase -> (* Add Lwt_main.run to toplevel evals. *) let phrase = if UTop.get_auto_run_lwt () then insert_lwt_main_run phrase else phrase in + (* Add Async execution to toplevel evals. *) + let phrase = if UTop.get_auto_run_async () then insert_async_main_run phrase else phrase in (* Set the margin of standard formatters. *) let cols = (LTerm.size term).cols in update_margin Format.std_formatter cols; @@ -564,6 +628,7 @@ module Emacs(M : sig end) = struct if add_to_history then LTerm_history.add UTop.history input; (* Add Lwt_main.run to toplevel evals. *) let phrase = if UTop.get_auto_run_lwt () then insert_lwt_main_run phrase else phrase in + let phrase = if UTop.get_auto_run_async () then insert_async_main_run phrase else phrase in try ignore (Toploop.execute_phrase true Format.std_formatter phrase) with exn ->