diff --git a/bin/main.ml b/bin/main.ml index 017f5432..62b7fc1f 100644 --- a/bin/main.ml +++ b/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@}: 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 = diff --git a/src/build_system.ml b/src/build_system.ml index 208b50dc..f456fd16 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -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 = diff --git a/src/build_system.mli b/src/build_system.mli index 37afcb5d..0099770c 100644 --- a/src/build_system.mli +++ b/src/build_system.mli @@ -66,3 +66,5 @@ val build_rules val all_targets_ever_built : unit -> Path.t list + +val dump_trace : t -> unit diff --git a/src/gen_rules.ml b/src/gen_rules.ml index a906c98b..7cfc2553 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -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 () = diff --git a/src/jbuild.ml b/src/jbuild.ml index 14298b07..ce914388 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -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 diff --git a/src/jbuild.mli b/src/jbuild.mli index a11147a6..583825b3 100644 --- a/src/jbuild.mli +++ b/src/jbuild.mli @@ -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 diff --git a/src/main.ml b/src/main.ml index b9df019c..569a2b51 100644 --- a/src/main.ml +++ b/src/main.ml @@ -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@}: Context %S not found!@." name; + die "" diff --git a/src/main.mli b/src/main.mli index 949ebb5e..f7167eb8 100644 --- a/src/main.mli +++ b/src/main.mli @@ -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 diff --git a/src/merlin.ml b/src/merlin.ml index 1e99a7fc..7d351d28 100644 --- a/src/merlin.ml +++ b/src/merlin.ml @@ -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 diff --git a/src/merlin.mli b/src/merlin.mli index d663d0c9..3d93830e 100644 --- a/src/merlin.mli +++ b/src/merlin.mli @@ -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 diff --git a/src/utop.ml b/src/utop.ml new file mode 100644 index 00000000..74bbe74d --- /dev/null +++ b/src/utop.ml @@ -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 "@[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) diff --git a/src/utop.mli b/src/utop.mli new file mode 100644 index 00000000..3428bfdd --- /dev/null +++ b/src/utop.mli @@ -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. *)