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 () = suggest_function := Jbuilder_cmdliner.Cmdliner_suggest.value
|
||||||
|
|
||||||
let (>>=) = Future.(>>=)
|
let (>>=) = Future.(>>=)
|
||||||
|
let (>>|) = Future.(>>|)
|
||||||
|
|
||||||
type common =
|
type common =
|
||||||
{ concurrency : int
|
{ concurrency : int
|
||||||
|
@ -44,6 +45,20 @@ let set_common c ~targets =
|
||||||
; 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
|
module Main = struct
|
||||||
include Jbuilder.Main
|
include Jbuilder.Main
|
||||||
|
|
||||||
|
@ -780,6 +795,11 @@ let install_uninstall ~what =
|
||||||
let install = install_uninstall ~what:"install"
|
let install = install_uninstall ~what:"install"
|
||||||
let uninstall = install_uninstall ~what:"uninstall"
|
let uninstall = install_uninstall ~what:"uninstall"
|
||||||
|
|
||||||
|
let context_arg ~doc =
|
||||||
|
Arg.(value
|
||||||
|
& opt string "default"
|
||||||
|
& info ["context"] ~docv:"CONTEXT" ~doc)
|
||||||
|
|
||||||
let exec =
|
let exec =
|
||||||
let doc =
|
let doc =
|
||||||
"Execute a command in a similar environment as if installation was performed."
|
"Execute a command in a similar environment as if installation was performed."
|
||||||
|
@ -799,13 +819,7 @@ let exec =
|
||||||
set_common common ~targets:[];
|
set_common common ~targets:[];
|
||||||
let log = Log.create () in
|
let log = Log.create () in
|
||||||
let setup = Future.Scheduler.go ~log (Main.setup ~log common) in
|
let setup = Future.Scheduler.go ~log (Main.setup ~log common) in
|
||||||
let context =
|
let context = Main.find_context_exn setup ~name:context in
|
||||||
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 path = Config.local_install_bin_dir ~context:context.name :: context.path in
|
let path = Config.local_install_bin_dir ~context:context.name :: context.path in
|
||||||
match Bin.which ~path prog with
|
match Bin.which ~path prog with
|
||||||
| None ->
|
| None ->
|
||||||
|
@ -815,26 +829,11 @@ let exec =
|
||||||
let real_prog = Path.to_string real_prog in
|
let real_prog = Path.to_string real_prog in
|
||||||
let env = Context.env_for_exec context in
|
let env = Context.env_for_exec context in
|
||||||
let argv = Array.of_list (prog :: args) in
|
let argv = Array.of_list (prog :: args) in
|
||||||
if Sys.win32 then
|
execve real_prog argv env
|
||||||
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
|
|
||||||
in
|
in
|
||||||
( Term.(const go
|
( Term.(const go
|
||||||
$ common
|
$ common
|
||||||
$ Arg.(value
|
$ context_arg ~doc:{|Run the command in this build context.|}
|
||||||
& opt string "default"
|
|
||||||
& info ["context"] ~docv:"CONTEXT"
|
|
||||||
~doc:{|Run the command in this build context.|}
|
|
||||||
)
|
|
||||||
$ Arg.(required
|
$ Arg.(required
|
||||||
& pos 0 (some string) None (Arg.info [] ~docv:"PROG"))
|
& pos 0 (some string) None (Arg.info [] ~docv:"PROG"))
|
||||||
$ Arg.(value
|
$ Arg.(value
|
||||||
|
@ -901,6 +900,42 @@ let subst =
|
||||||
)
|
)
|
||||||
, Term.info "subst" ~doc ~man)
|
, 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 =
|
let all =
|
||||||
[ installed_libraries
|
[ installed_libraries
|
||||||
; external_lib_deps
|
; external_lib_deps
|
||||||
|
@ -912,6 +947,7 @@ let all =
|
||||||
; exec
|
; exec
|
||||||
; subst
|
; subst
|
||||||
; rules
|
; rules
|
||||||
|
; utop
|
||||||
]
|
]
|
||||||
|
|
||||||
let default =
|
let default =
|
||||||
|
|
|
@ -572,6 +572,8 @@ let all_targets_ever_built () =
|
||||||
else
|
else
|
||||||
[]
|
[]
|
||||||
|
|
||||||
|
let dump_trace t = Trace.dump t.trace
|
||||||
|
|
||||||
let create ~contexts ~file_tree ~rules =
|
let create ~contexts ~file_tree ~rules =
|
||||||
let all_source_files =
|
let all_source_files =
|
||||||
File_tree.fold file_tree ~init:Pset.empty ~f:(fun dir acc ->
|
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
|
setup_copy_rules t ~all_targets_by_dir
|
||||||
~all_non_target_source_files:
|
~all_non_target_source_files:
|
||||||
(Pset.diff all_source_files all_other_targets);
|
(Pset.diff all_source_files all_other_targets);
|
||||||
at_exit (fun () -> Trace.dump t.trace);
|
at_exit (fun () -> dump_trace t);
|
||||||
t
|
t
|
||||||
|
|
||||||
let remove_old_artifacts t =
|
let remove_old_artifacts t =
|
||||||
|
|
|
@ -66,3 +66,5 @@ val build_rules
|
||||||
val all_targets_ever_built
|
val all_targets_ever_built
|
||||||
: unit
|
: unit
|
||||||
-> Path.t list
|
-> 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 ->
|
List.filter_map stanzas ~f:(fun stanza ->
|
||||||
let dir = ctx_dir in
|
let dir = ctx_dir in
|
||||||
match (stanza : Stanza.t) with
|
match (stanza : Stanza.t) with
|
||||||
| Library lib ->
|
| Library lib ->
|
||||||
Some (library_rules lib ~dir
|
Some (library_rules lib ~dir ~all_modules:(Lazy.force all_modules)
|
||||||
~all_modules:(Lazy.force all_modules) ~files:(Lazy.force files)
|
~files:(Lazy.force files) ~scope)
|
||||||
~scope)
|
| Executables exes ->
|
||||||
| Executables exes ->
|
Some (executables_rules exes ~dir ~all_modules:(Lazy.force all_modules) ~scope)
|
||||||
Some (executables_rules exes ~dir ~all_modules:(Lazy.force all_modules)
|
|
||||||
~scope)
|
|
||||||
| _ -> None)
|
| _ -> 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 () = List.iter (SC.stanzas sctx) ~f:rules
|
||||||
let () =
|
let () =
|
||||||
|
|
|
@ -282,6 +282,8 @@ module Preprocess_map = struct
|
||||||
type t = Preprocess.t Per_module.t
|
type t = Preprocess.t Per_module.t
|
||||||
let t = Per_module.t Preprocess.t
|
let t = Per_module.t Preprocess.t
|
||||||
|
|
||||||
|
let no_preprocessing = Per_module.For_all Preprocess.No_preprocessing
|
||||||
|
|
||||||
let find module_name (t : t) =
|
let find module_name (t : t) =
|
||||||
match t with
|
match t with
|
||||||
| For_all pp -> pp
|
| For_all pp -> pp
|
||||||
|
|
|
@ -46,6 +46,9 @@ end
|
||||||
module Preprocess_map : sig
|
module Preprocess_map : sig
|
||||||
type t
|
type t
|
||||||
|
|
||||||
|
val no_preprocessing : t
|
||||||
|
val default : t
|
||||||
|
|
||||||
(** [find module_name] find the preprocessing specification for a given module *)
|
(** [find module_name] find the preprocessing specification for a given module *)
|
||||||
val find : string -> t -> Preprocess.t
|
val find : string -> t -> Preprocess.t
|
||||||
|
|
||||||
|
@ -57,6 +60,8 @@ module Js_of_ocaml : sig
|
||||||
{ flags : Ordered_set_lang.Unexpanded.t
|
{ flags : Ordered_set_lang.Unexpanded.t
|
||||||
; javascript_files : string list
|
; javascript_files : string list
|
||||||
}
|
}
|
||||||
|
|
||||||
|
val default : t
|
||||||
end
|
end
|
||||||
|
|
||||||
module Lib_dep : sig
|
module Lib_dep : sig
|
||||||
|
|
|
@ -220,3 +220,10 @@ let bootstrap () =
|
||||||
exit 1
|
exit 1
|
||||||
|
|
||||||
let setup = setup ~use_findlib:true ~extra_ignored_subtrees:Path.Set.empty
|
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 report_error : ?map_fname:(string -> string) -> Format.formatter -> exn -> unit
|
||||||
|
|
||||||
val bootstrap : unit -> 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
|
| 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
|
if (SC.context sctx).merlin then
|
||||||
match ts with
|
dot_merlin sctx ~dir merlin
|
||||||
| [] -> ()
|
|
||||||
| t :: ts -> dot_merlin sctx ~dir (List.fold_left ts ~init:t ~f:merge_two)
|
|
||||||
|
|
|
@ -7,6 +7,8 @@ type t =
|
||||||
; libname : string option
|
; libname : string option
|
||||||
}
|
}
|
||||||
|
|
||||||
(** Add rules for generating the .merlin in a directory *)
|
val merge_all : t list -> t option
|
||||||
val add_rules : Super_context.t -> dir:Path.t -> t list -> unit
|
|
||||||
|
(** 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