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.

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 =

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 =

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

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 () =

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

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

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>Error@}: Context %S not found!@." name;
+    die ""

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

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

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
 

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 "@[<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)

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. *)