Add a utop subcommand (#183)
Add a utop subcommand that build and execute a utop where all the libraries defined in the current directory are immediately available for interactive use.
This commit is contained in:
parent
46df511dd4
commit
b668d9189f
84
bin/main.ml
84
bin/main.ml
|
@ -7,6 +7,7 @@ open Jbuilder_cmdliner.Cmdliner
|
|||
let () = suggest_function := Jbuilder_cmdliner.Cmdliner_suggest.value
|
||||
|
||||
let (>>=) = Future.(>>=)
|
||||
let (>>|) = Future.(>>|)
|
||||
|
||||
type common =
|
||||
{ concurrency : int
|
||||
|
@ -44,6 +45,20 @@ let set_common c ~targets =
|
|||
; targets
|
||||
]
|
||||
|
||||
let execve =
|
||||
if Sys.win32 then
|
||||
fun prog argv env ->
|
||||
let pid = Unix.create_process_env prog argv env
|
||||
Unix.stdin Unix.stdout Unix.stderr
|
||||
in
|
||||
match snd (Unix.waitpid [] pid) with
|
||||
| WEXITED 0 -> ()
|
||||
| WEXITED n -> exit n
|
||||
| WSIGNALED _ -> exit 255
|
||||
| WSTOPPED _ -> assert false
|
||||
else
|
||||
Unix.execve
|
||||
|
||||
module Main = struct
|
||||
include Jbuilder.Main
|
||||
|
||||
|
@ -780,6 +795,11 @@ let install_uninstall ~what =
|
|||
let install = install_uninstall ~what:"install"
|
||||
let uninstall = install_uninstall ~what:"uninstall"
|
||||
|
||||
let context_arg ~doc =
|
||||
Arg.(value
|
||||
& opt string "default"
|
||||
& info ["context"] ~docv:"CONTEXT" ~doc)
|
||||
|
||||
let exec =
|
||||
let doc =
|
||||
"Execute a command in a similar environment as if installation was performed."
|
||||
|
@ -799,13 +819,7 @@ let exec =
|
|||
set_common common ~targets:[];
|
||||
let log = Log.create () in
|
||||
let setup = Future.Scheduler.go ~log (Main.setup ~log common) in
|
||||
let context =
|
||||
match List.find setup.contexts ~f:(fun c -> c.name = context) with
|
||||
| Some ctx -> ctx
|
||||
| None ->
|
||||
Format.eprintf "@{<Error>Error@}: Context %S not found!@." context;
|
||||
die ""
|
||||
in
|
||||
let context = Main.find_context_exn setup ~name:context in
|
||||
let path = Config.local_install_bin_dir ~context:context.name :: context.path in
|
||||
match Bin.which ~path prog with
|
||||
| None ->
|
||||
|
@ -815,26 +829,11 @@ let exec =
|
|||
let real_prog = Path.to_string real_prog in
|
||||
let env = Context.env_for_exec context in
|
||||
let argv = Array.of_list (prog :: args) in
|
||||
if Sys.win32 then
|
||||
let pid =
|
||||
Unix.create_process_env real_prog argv env
|
||||
Unix.stdin Unix.stdout Unix.stderr
|
||||
in
|
||||
match snd (Unix.waitpid [] pid) with
|
||||
| WEXITED 0 -> ()
|
||||
| WEXITED n -> exit n
|
||||
| WSIGNALED _ -> exit 255
|
||||
| WSTOPPED _ -> assert false
|
||||
else
|
||||
Unix.execve real_prog argv env
|
||||
execve real_prog argv env
|
||||
in
|
||||
( Term.(const go
|
||||
$ common
|
||||
$ Arg.(value
|
||||
& opt string "default"
|
||||
& info ["context"] ~docv:"CONTEXT"
|
||||
~doc:{|Run the command in this build context.|}
|
||||
)
|
||||
$ context_arg ~doc:{|Run the command in this build context.|}
|
||||
$ Arg.(required
|
||||
& pos 0 (some string) None (Arg.info [] ~docv:"PROG"))
|
||||
$ Arg.(value
|
||||
|
@ -901,6 +900,42 @@ let subst =
|
|||
)
|
||||
, Term.info "subst" ~doc ~man)
|
||||
|
||||
let utop =
|
||||
let doc = "Load library in utop" in
|
||||
let man =
|
||||
[ `S "DESCRIPTION"
|
||||
; `P {|$(b,jbuilder utop DIR) build and run utop toplevel with libraries defined in DIR|}
|
||||
; `Blocks help_secs
|
||||
] in
|
||||
let go common dir ctx_name args =
|
||||
let utop_target = dir |> Path.of_string |> Utop.utop_exe |> Path.to_string in
|
||||
set_common common ~targets:[utop_target];
|
||||
let log = Log.create () in
|
||||
let (build_system, context, utop_path) =
|
||||
(Main.setup ~log common >>= fun setup ->
|
||||
let context = Main.find_context_exn setup ~name:ctx_name in
|
||||
let setup = { setup with contexts = [context] } in
|
||||
let target =
|
||||
match resolve_targets ~log common setup [utop_target] with
|
||||
| [] -> die "no libraries defined in %s" dir
|
||||
| [target] -> target
|
||||
| _::_::_ -> assert false
|
||||
in
|
||||
do_build setup [target] >>| fun () ->
|
||||
(setup.build_system, context, Path.to_string target)
|
||||
) |> Future.Scheduler.go ~log in
|
||||
Build_system.dump_trace build_system;
|
||||
execve utop_path (Array.of_list (utop_path :: args))
|
||||
(Context.env_for_exec context)
|
||||
in
|
||||
let name_ = Arg.info [] ~docv:"PATH" in
|
||||
( Term.(const go
|
||||
$ common
|
||||
$ Arg.(value & pos 0 dir "" name_)
|
||||
$ context_arg ~doc:{|Select context where to build/run utop.|}
|
||||
$ Arg.(value & pos_right 0 string [] (Arg.info [] ~docv:"ARGS")))
|
||||
, Term.info "utop" ~doc ~man )
|
||||
|
||||
let all =
|
||||
[ installed_libraries
|
||||
; external_lib_deps
|
||||
|
@ -912,6 +947,7 @@ let all =
|
|||
; exec
|
||||
; subst
|
||||
; rules
|
||||
; utop
|
||||
]
|
||||
|
||||
let default =
|
||||
|
|
|
@ -572,6 +572,8 @@ let all_targets_ever_built () =
|
|||
else
|
||||
[]
|
||||
|
||||
let dump_trace t = Trace.dump t.trace
|
||||
|
||||
let create ~contexts ~file_tree ~rules =
|
||||
let all_source_files =
|
||||
File_tree.fold file_tree ~init:Pset.empty ~f:(fun dir acc ->
|
||||
|
@ -615,7 +617,7 @@ let create ~contexts ~file_tree ~rules =
|
|||
setup_copy_rules t ~all_targets_by_dir
|
||||
~all_non_target_source_files:
|
||||
(Pset.diff all_source_files all_other_targets);
|
||||
at_exit (fun () -> Trace.dump t.trace);
|
||||
at_exit (fun () -> dump_trace t);
|
||||
t
|
||||
|
||||
let remove_old_artifacts t =
|
||||
|
|
|
@ -66,3 +66,5 @@ val build_rules
|
|||
val all_targets_ever_built
|
||||
: unit
|
||||
-> Path.t list
|
||||
|
||||
val dump_trace : t -> unit
|
||||
|
|
|
@ -707,15 +707,20 @@ Add it to your jbuild file to remove this warning.
|
|||
List.filter_map stanzas ~f:(fun stanza ->
|
||||
let dir = ctx_dir in
|
||||
match (stanza : Stanza.t) with
|
||||
| Library lib ->
|
||||
Some (library_rules lib ~dir
|
||||
~all_modules:(Lazy.force all_modules) ~files:(Lazy.force files)
|
||||
~scope)
|
||||
| Executables exes ->
|
||||
Some (executables_rules exes ~dir ~all_modules:(Lazy.force all_modules)
|
||||
~scope)
|
||||
| Library lib ->
|
||||
Some (library_rules lib ~dir ~all_modules:(Lazy.force all_modules)
|
||||
~files:(Lazy.force files) ~scope)
|
||||
| Executables exes ->
|
||||
Some (executables_rules exes ~dir ~all_modules:(Lazy.force all_modules) ~scope)
|
||||
| _ -> None)
|
||||
|> Merlin.add_rules sctx ~dir:ctx_dir
|
||||
|> Merlin.merge_all
|
||||
|> Option.iter ~f:(Merlin.add_rules sctx ~dir:ctx_dir);
|
||||
Option.iter (Utop.exe_stanzas stanzas) ~f:(fun (exe, all_modules) ->
|
||||
let dir = Utop.utop_exe_dir ~dir:ctx_dir in
|
||||
let merlin = executables_rules exe ~dir ~all_modules ~scope in
|
||||
Merlin.add_rules sctx ~dir merlin;
|
||||
Utop.add_module_rules sctx ~dir merlin.requires;
|
||||
)
|
||||
|
||||
let () = List.iter (SC.stanzas sctx) ~f:rules
|
||||
let () =
|
||||
|
|
|
@ -282,6 +282,8 @@ module Preprocess_map = struct
|
|||
type t = Preprocess.t Per_module.t
|
||||
let t = Per_module.t Preprocess.t
|
||||
|
||||
let no_preprocessing = Per_module.For_all Preprocess.No_preprocessing
|
||||
|
||||
let find module_name (t : t) =
|
||||
match t with
|
||||
| For_all pp -> pp
|
||||
|
|
|
@ -46,6 +46,9 @@ end
|
|||
module Preprocess_map : sig
|
||||
type t
|
||||
|
||||
val no_preprocessing : t
|
||||
val default : t
|
||||
|
||||
(** [find module_name] find the preprocessing specification for a given module *)
|
||||
val find : string -> t -> Preprocess.t
|
||||
|
||||
|
@ -57,6 +60,8 @@ module Js_of_ocaml : sig
|
|||
{ flags : Ordered_set_lang.Unexpanded.t
|
||||
; javascript_files : string list
|
||||
}
|
||||
|
||||
val default : t
|
||||
end
|
||||
|
||||
module Lib_dep : sig
|
||||
|
|
|
@ -220,3 +220,10 @@ let bootstrap () =
|
|||
exit 1
|
||||
|
||||
let setup = setup ~use_findlib:true ~extra_ignored_subtrees:Path.Set.empty
|
||||
|
||||
let find_context_exn t ~name =
|
||||
match List.find t.contexts ~f:(fun c -> c.name = name) with
|
||||
| Some ctx -> ctx
|
||||
| None ->
|
||||
Format.eprintf "@{<Error>Error@}: Context %S not found!@." name;
|
||||
die ""
|
||||
|
|
|
@ -28,3 +28,5 @@ val external_lib_deps
|
|||
val report_error : ?map_fname:(string -> string) -> Format.formatter -> exn -> unit
|
||||
|
||||
val bootstrap : unit -> unit
|
||||
|
||||
val find_context_exn : setup -> name:string -> Context.t
|
||||
|
|
|
@ -99,8 +99,10 @@ let merge_two a b =
|
|||
| None -> b.libname
|
||||
}
|
||||
|
||||
let add_rules sctx ~dir ts =
|
||||
let merge_all = function
|
||||
| [] -> None
|
||||
| init::ts -> Some (List.fold_left ~init ~f:merge_two ts)
|
||||
|
||||
let add_rules sctx ~dir merlin =
|
||||
if (SC.context sctx).merlin then
|
||||
match ts with
|
||||
| [] -> ()
|
||||
| t :: ts -> dot_merlin sctx ~dir (List.fold_left ts ~init:t ~f:merge_two)
|
||||
dot_merlin sctx ~dir merlin
|
||||
|
|
|
@ -7,6 +7,8 @@ type t =
|
|||
; libname : string option
|
||||
}
|
||||
|
||||
(** Add rules for generating the .merlin in a directory *)
|
||||
val add_rules : Super_context.t -> dir:Path.t -> t list -> unit
|
||||
val merge_all : t list -> t option
|
||||
|
||||
(** Add rules for generating the .merlin in a directory *)
|
||||
val add_rules : Super_context.t -> dir:Path.t -> t -> unit
|
||||
|
||||
|
|
|
@ -0,0 +1,84 @@
|
|||
open Import
|
||||
open Jbuild
|
||||
open Build.O
|
||||
open! No_io
|
||||
|
||||
let exe_name = "utop"
|
||||
let module_name = String.capitalize_ascii exe_name
|
||||
let module_filename = exe_name ^ ".ml"
|
||||
|
||||
let pp_ml fmt include_dirs =
|
||||
let pp_include fmt =
|
||||
let pp_sep fmt () = Format.fprintf fmt "@ ; " in
|
||||
Format.pp_print_list ~pp_sep (fun fmt p ->
|
||||
Format.fprintf fmt {|"%s"|} (Path.to_string p)
|
||||
) fmt
|
||||
in
|
||||
Format.fprintf fmt "@[<v 2>Clflags.include_dirs :=@ [ %a@ ]@];@."
|
||||
pp_include include_dirs;
|
||||
Format.fprintf fmt "@.UTop_main.main ();@."
|
||||
|
||||
let add_module_rules sctx ~dir lib_requires =
|
||||
let path = Path.relative dir module_filename in
|
||||
let utop_ml =
|
||||
lib_requires
|
||||
>>^ (fun libs ->
|
||||
let include_paths = Path.Set.elements (Lib.include_paths libs) in
|
||||
let b = Buffer.create 64 in
|
||||
let fmt = Format.formatter_of_buffer b in
|
||||
pp_ml fmt include_paths;
|
||||
Format.pp_print_flush fmt ();
|
||||
Buffer.contents b)
|
||||
>>> Build.update_file_dyn path in
|
||||
Super_context.add_rule sctx utop_ml
|
||||
|
||||
let utop_of_libs (libs : Library.t list) =
|
||||
{ Executables.names = [exe_name]
|
||||
; link_executables = true
|
||||
; link_flags = Ordered_set_lang.Unexpanded.t (
|
||||
Sexp.add_loc ~loc:Loc.none (List [Atom "-linkall"])
|
||||
)
|
||||
; modes = Mode.Dict.Set.of_list [Mode.Byte]
|
||||
; buildable =
|
||||
{ Buildable.modules =
|
||||
Ordered_set_lang.t (List (Loc.none, [Atom (Loc.none, module_name)]))
|
||||
; libraries =
|
||||
(Lib_dep.direct "utop") :: (List.map libs ~f:(fun lib ->
|
||||
Lib_dep.direct lib.Library.name))
|
||||
; preprocess = Preprocess_map.no_preprocessing
|
||||
; preprocessor_deps = []
|
||||
; flags = Ordered_set_lang.Unexpanded.standard
|
||||
; ocamlc_flags = Ordered_set_lang.Unexpanded.standard
|
||||
; ocamlopt_flags = Ordered_set_lang.Unexpanded.standard
|
||||
; js_of_ocaml = Js_of_ocaml.default
|
||||
}
|
||||
}
|
||||
|
||||
let exe_stanzas stanzas =
|
||||
let libs =
|
||||
List.filter_map stanzas ~f:(function
|
||||
| Stanza.Library lib -> Some lib
|
||||
| _ -> None
|
||||
) in
|
||||
match libs with
|
||||
| [] -> None
|
||||
| libs ->
|
||||
let all_modules =
|
||||
String_map.of_alist_exn
|
||||
[ module_name
|
||||
, { Module.
|
||||
name = module_name
|
||||
; impl = { Module.File.
|
||||
name = module_filename
|
||||
; syntax = Module.Syntax.OCaml
|
||||
}
|
||||
; intf = None
|
||||
; obj_name = "" }
|
||||
] in
|
||||
Some (utop_of_libs libs, all_modules)
|
||||
|
||||
let utop_exe_dir ~dir = Path.relative dir ".utop"
|
||||
|
||||
let utop_exe dir =
|
||||
Path.relative (utop_exe_dir ~dir) exe_name
|
||||
|> Path.extend_basename ~suffix:(Mode.exe_ext Mode.Byte)
|
|
@ -0,0 +1,26 @@
|
|||
(** Utop rules *)
|
||||
|
||||
open Import
|
||||
|
||||
val exe_stanzas
|
||||
: Jbuild.Stanza.t list
|
||||
-> (Jbuild.Executables.t * Module.t String_map.t) option
|
||||
(** Given a list of stanzas (from a directory with a jbuild file) return:
|
||||
1. a stanza for a utop toplevel with all the libraries linked in.
|
||||
2. an entry module that will be used to create the toplevel *)
|
||||
|
||||
val add_module_rules
|
||||
: Super_context.t
|
||||
-> dir:Path.t
|
||||
-> (unit, Lib.t list) Build.t
|
||||
-> unit
|
||||
(** Add rules to generate a utop module that will all have all the include dirs
|
||||
for the dependencies *)
|
||||
|
||||
val utop_exe_dir : dir:Path.t -> Path.t
|
||||
(** Return the directory in which the main module for the top level will be
|
||||
generated. *)
|
||||
|
||||
val utop_exe : Path.t -> Path.t
|
||||
(** Return the path of the utop bytecode binary inside a directory where
|
||||
some libraries are defined. *)
|
Loading…
Reference in New Issue