unikernel/duniverse/dune_/bin/ocaml/doc.ml

@@ -0,0 +1,68 @@
+open Import
+module Main = Import.Main
+
+let doc = "Build and view the documentation of an OCaml project"
+
+let man =
+  [ `S "DESCRIPTION"
+  ; `P
+      {|$(b,dune ocaml doc) builds and then opens the documentation of an OCaml project in the users default browser.|}
+  ; `Blocks Common.help_secs
+  ]
+;;
+
+let info = Cmd.info "doc" ~doc ~man
+
+let lock_odoc_if_dev_tool_enabled () =
+  match Lazy.force Lock_dev_tool.is_enabled with
+  | false -> Action_builder.return ()
+  | true -> Action_builder.of_memo (Lock_dev_tool.lock_dev_tool Odoc)
+;;
+
+let term =
+  let+ builder = Common.Builder.term in
+  let common, config = Common.init builder in
+  let request (setup : Main.build_system) =
+    let dir = Path.(relative root) (Common.prefix_target common ".") in
+    let open Action_builder.O in
+    let* () = lock_odoc_if_dev_tool_enabled () in
+    let+ () =
+      Alias.in_dir ~name:Dune_rules.Alias.doc ~recursive:true ~contexts:setup.contexts dir
+      |> Alias.request
+    in
+    let relative_toplevel_index_path =
+      let toplevel_index_path =
+        let is_default ctx = ctx |> Context.name |> Dune_engine.Context_name.is_default in
+        let doc_ctx = List.find_exn setup.contexts ~f:is_default in
+        Dune_rules.Odoc.Paths.toplevel_index doc_ctx
+      in
+      Path.(toplevel_index_path |> build |> to_string_maybe_quoted)
+    in
+    Console.print
+      [ Pp.textf "Docs built. Index can be found here: %s" relative_toplevel_index_path ];
+    match
+      let open Option.O in
+      let* cmd_name, args =
+        match Platform.OS.value with
+        | Darwin -> Some ("open", [])
+        | Other | FreeBSD | NetBSD | OpenBSD | Haiku | Linux -> Some ("xdg-open", [])
+        | Windows -> None
+      in
+      let+ open_command =
+        let path = Env_path.path Env.initial in
+        Bin.which ~path cmd_name
+      in
+      open_command, args @ [ relative_toplevel_index_path ]
+    with
+    | Some (cmd, args) ->
+      Proc.restore_cwd_and_execve (Path.to_absolute_filename cmd) args ~env:Env.initial
+    | None ->
+      User_warning.emit
+        [ Pp.text
+            "No browser could be found, you will have to open the documentation yourself."
+        ]
+  in
+  Build.run_build_command ~common ~config ~request
+;;
+
+let cmd = Cmd.v info term

unikernel/duniverse/dune_/bin/ocaml/doc.mli

@@ -0,0 +1,3 @@
+open! Import
+
+val cmd : unit Cmd.t

unikernel/duniverse/dune_/bin/ocaml/ocaml_cmd.ml

@@ -0,0 +1,16 @@
+open Import
+
+let info = Cmd.info "ocaml" ~doc:"Command group related to OCaml."
+
+let group =
+  Cmdliner.Cmd.group
+    info
+    [ Utop.command
+    ; Ocaml_merlin.command
+    ; Ocaml_merlin.Dump_dot_merlin.command
+    ; Top.command
+    ; Top.module_command
+    ; Ocaml_merlin.group
+    ; Doc.cmd
+    ]
+;;

unikernel/duniverse/dune_/bin/ocaml/ocaml_cmd.mli

@@ -0,0 +1,3 @@
+open Import
+
+val group : unit Cmd.t

unikernel/duniverse/dune_/bin/ocaml/ocaml_merlin.ml

@@ -0,0 +1,317 @@
+open Import
+
+module Selected_context = struct
+  let arg =
+    let ctx_name_conv =
+      let parse ctx_name =
+        match Context_name.of_string_opt ctx_name with
+        | None -> Error (`Msg (Printf.sprintf "Invalid context name %S" ctx_name))
+        | Some ctx_name -> Ok ctx_name
+      in
+      let print ppf t = Stdlib.Format.fprintf ppf "%s" (Context_name.to_string t) in
+      Arg.conv ~docv:"context" (parse, print)
+    in
+    Arg.(
+      value
+      & opt ctx_name_conv Context_name.default
+      & info
+          [ "context" ]
+          ~docv:"CONTEXT"
+          ~doc:"Select the Dune build context that will be used to return information")
+  ;;
+end
+
+module Server : sig
+  val dump : selected_context:Context_name.t -> string -> unit Fiber.t
+  val dump_dot_merlin : selected_context:Context_name.t -> string -> unit Fiber.t
+
+  (** Once started the server will wait for commands on stdin, read the
+      requested merlin dot file and return its content on stdout. The server
+      will halt when receiving EOF of a bad csexp. *)
+  val start : selected_context:Context_name.t -> unit -> unit Fiber.t
+end = struct
+  open Fiber.O
+
+  module Merlin_conf = struct
+    type t = Sexp.t
+
+    let make_error msg = Sexp.(List [ List [ Atom "ERROR"; Atom msg ] ])
+
+    let to_stdout (t : t) =
+      Csexp.to_channel stdout t;
+      flush stdout
+    ;;
+  end
+
+  module Commands = struct
+    type t =
+      | File of string
+      | Halt
+      | Unknown of string
+
+    let read_input in_channel =
+      match Csexp.input_opt in_channel with
+      | Ok None -> Halt
+      | Ok (Some sexp) ->
+        let open Sexp in
+        (match sexp with
+         | Atom "Halt" -> Halt
+         | List [ Atom "File"; Atom path ] -> File path
+         | sexp ->
+           let msg = Printf.sprintf "Bad input: %s" (Sexp.to_string sexp) in
+           Unknown msg)
+      | Error err ->
+        Format.eprintf "Bad input: %s@." err;
+        Halt
+    ;;
+  end
+
+  (* [make_relative_to_root p] will check that [Path.root] is a prefix of the
+     absolute path [p] and remove it if that is the case. Under Windows and
+     Cygwin environment both paths are lowarcased before the comparison *)
+  let make_relative_to_root p =
+    let p = Path.to_absolute_filename p in
+    let prefix = Path.(to_absolute_filename root) in
+    (if Sys.win32 || Sys.cygwin then String.Caseless.drop_prefix else String.drop_prefix)
+      ~prefix
+      p
+    (* After dropping the prefix we need to remove the leading path separator *)
+    |> Option.map ~f:(fun s -> String.drop s 1)
+  ;;
+
+  (* Given a path [p] relative to the workspace root, [get_merlin_files_paths p]
+     navigates to the [_build] directory and reaches this path from the correct
+     context. Then it returns the list of available Merlin configurations for
+     this directory. *)
+  let get_merlin_files_paths dir =
+    let merlin_path =
+      Path.Build.relative dir Dune_rules.Merlin_ident.merlin_folder_name
+    in
+    Path.build merlin_path
+    |> Path.readdir_unsorted
+    |> Result.value ~default:[]
+    |> List.sort ~compare:String.compare
+    |> List.map ~f:(fun f -> Path.Build.relative merlin_path f |> Path.build)
+  ;;
+
+  module Merlin = Dune_rules.Merlin
+
+  let load_merlin_file file =
+    (* We search for an appropriate merlin configuration in the current
+       directory and its parents *)
+    let rec find_closest path =
+      match
+        get_merlin_files_paths path
+        |> List.find_map ~f:(fun file_path ->
+          (* FIXME we are racing against the build system writing these
+             files here *)
+          match Merlin.Processed.load_file file_path with
+          | Error msg -> Some (Merlin_conf.make_error msg)
+          | Ok config -> Merlin.Processed.get config ~file)
+      with
+      | Some p -> Some p
+      | None ->
+        (match Path.Build.parent path with
+         | None -> None
+         | Some dir -> find_closest dir)
+    in
+    match find_closest (Path.Build.parent_exn file) with
+    | Some x -> x
+    | None ->
+      Path.Build.drop_build_context_exn file
+      |> Path.Source.to_string_maybe_quoted
+      |> Printf.sprintf "No config found for file %s. Try calling 'dune build'."
+      |> Merlin_conf.make_error
+  ;;
+
+  (* [to_local p] makes path [p] relative to the project's root. [p] can be: -
+     An absolute path - A path relative to [Path.initial_cwd] *)
+  let to_local file_path =
+    let error msg = Error msg in
+    (* This ensure the path is absolute. If not it is prefixed with
+       [Path.initial_cwd] *)
+    let abs_file_path = Path.of_filename_relative_to_initial_cwd file_path in
+    (* Then we make the path relative to [Path.root] (and not
+       [Path.initial_cwd]) *)
+    match make_relative_to_root abs_file_path with
+    | Some path ->
+      (try
+         let path = Path.of_string path in
+         (* If dune ocaml-merlin is called from within the build dir we must
+            remove the build context *)
+         Ok (Path.drop_optional_build_context path |> Path.local_part)
+       with
+       | User_error.E mess -> User_message.to_string mess |> error)
+    | None ->
+      Printf.sprintf
+        "Path %s is not in dune workspace (%s)."
+        (String.maybe_quoted file_path)
+        (String.maybe_quoted @@ Path.(to_absolute_filename Path.root))
+      |> error
+  ;;
+
+  let to_local ~selected_context file =
+    match to_local file with
+    | Error s -> Fiber.return (Error s)
+    | Ok file ->
+      (match Dune_engine.Context_name.is_default selected_context with
+       | false ->
+         Fiber.return
+           (Ok (Path.Build.append_local (Context_name.build_dir selected_context) file))
+       | true ->
+         let+ workspace = Memo.run (Workspace.workspace ()) in
+         (match workspace.merlin_context with
+          | None -> Error "no merlin context configured"
+          | Some context ->
+            Ok (Path.Build.append_local (Context_name.build_dir context) file)))
+  ;;
+
+  let print_merlin_conf ~selected_context file =
+    to_local ~selected_context file
+    >>| (function
+     | Error s -> Merlin_conf.make_error s
+     | Ok file -> load_merlin_file file)
+    >>| Merlin_conf.to_stdout
+  ;;
+
+  let dump ~selected_context s =
+    to_local ~selected_context s
+    >>| function
+    | Error mess -> Printf.eprintf "%s\n%!" mess
+    | Ok path -> get_merlin_files_paths path |> List.iter ~f:Merlin.Processed.print_file
+  ;;
+
+  let dump_dot_merlin ~selected_context s =
+    to_local ~selected_context s
+    >>| function
+    | Error mess -> Printf.eprintf "%s\n%!" mess
+    | Ok path ->
+      let files = get_merlin_files_paths path in
+      Merlin.Processed.print_generic_dot_merlin files
+  ;;
+
+  let start ~selected_context () =
+    let open Fiber.O in
+    let rec main () =
+      match Commands.read_input stdin with
+      | Halt -> Fiber.return ()
+      | File path ->
+        let* () = print_merlin_conf ~selected_context path in
+        main ()
+      | Unknown msg ->
+        Merlin_conf.to_stdout (Merlin_conf.make_error msg);
+        main ()
+    in
+    main ()
+  ;;
+end
+
+module Dump_config = struct
+  let info =
+    Cmd.info
+      ~doc:
+        "Print the entire content of the merlin configuration for the given folder in a \
+         user friendly form. This is for testing and debugging purposes only and should \
+         not be considered as a stable output."
+      "dump-config"
+  ;;
+
+  let term =
+    let+ builder = Common.Builder.term
+    and+ dir = Arg.(value & pos 0 dir "" & info [] ~docv:"PATH")
+    and+ selected_context = Selected_context.arg in
+    let common, config =
+      let builder =
+        let builder = Common.Builder.forbid_builds builder in
+        Common.Builder.disable_log_file builder
+      in
+      Common.init builder
+    in
+    Scheduler.go_with_rpc_server ~common ~config (fun () ->
+      Server.dump ~selected_context dir)
+  ;;
+
+  let command = Cmd.v info term
+end
+
+let doc = "Start a merlin configuration server."
+
+let man =
+  [ `S "DESCRIPTION"
+  ; `P
+      {|$(b,dune ocaml-merlin) starts a server that can be queried to get
+      .merlin information. It is meant to be used by Merlin itself and does not
+      provide a user-friendly output.|}
+  ; `Blocks Common.help_secs
+  ; Common.footer
+  ]
+;;
+
+let start_session_info name = Cmd.info name ~doc ~man
+
+let start_session_term =
+  let+ builder = Common.Builder.term
+  and+ selected_context = Selected_context.arg in
+  let common, config =
+    let builder =
+      let builder = Common.Builder.forbid_builds builder in
+      Common.Builder.disable_log_file builder
+    in
+    Common.init builder
+  in
+  Scheduler.go_with_rpc_server ~common ~config (Server.start ~selected_context)
+;;
+
+let command = Cmd.v (start_session_info "ocaml-merlin") start_session_term
+
+module Dump_dot_merlin = struct
+  let doc = "Print Merlin configuration"
+
+  let man =
+    [ `S "DESCRIPTION"
+    ; `P
+        {|$(b,dune ocaml dump-dot-merlin) will attempt to read previously
+        generated configuration in a source folder, merge them and print
+        it to the standard output in Merlin configuration syntax. The
+        output of this command should always be checked and adapted to
+        the project needs afterward.|}
+    ; Common.footer
+    ]
+  ;;
+
+  let info = Cmd.info "dump-dot-merlin" ~doc ~man
+
+  let term =
+    let+ builder = Common.Builder.term
+    and+ path =
+      Arg.(
+        value
+        & pos 0 (some string) None
+        & info
+            []
+            ~docv:"PATH"
+            ~doc:
+              "The path to the folder of which the configuration should be printed. \
+               Defaults to the current directory.")
+    and+ selected_context = Selected_context.arg in
+    let common, config =
+      let builder =
+        let builder = Common.Builder.forbid_builds builder in
+        Common.Builder.disable_log_file builder
+      in
+      Common.init builder
+    in
+    Scheduler.go_with_rpc_server ~common ~config (fun () ->
+      match path with
+      | Some s -> Server.dump_dot_merlin ~selected_context s
+      | None -> Server.dump_dot_merlin ~selected_context ".")
+  ;;
+
+  let command = Cmd.v info term
+end
+
+let group =
+  Cmdliner.Cmd.group
+    (Cmd.info "merlin" ~doc:"Command group related to merlin")
+    [ Dump_config.command; Cmd.v (start_session_info "start-session") start_session_term ]
+;;

unikernel/duniverse/dune_/bin/ocaml/ocaml_merlin.mli

@@ -0,0 +1,9 @@
+open Import
+
+val command : unit Cmd.t
+
+module Dump_dot_merlin : sig
+  val command : unit Cmd.t
+end
+
+val group : unit Cmd.t

unikernel/duniverse/dune_/bin/ocaml/top.ml

@@ -0,0 +1,248 @@
+open Import
+
+let doc =
+  "Print a list of toplevel directives for including directories and loading cma files."
+;;
+
+let man =
+  [ `S "DESCRIPTION"
+  ; `P
+      {|Print a list of toplevel directives for including directories and loading cma files.|}
+  ; `P
+      {|The output of $(b,dune top) should be evaluated in a toplevel
+          to make a library available there.|}
+  ; `Blocks Common.help_secs
+  ]
+;;
+
+let info = Cmd.info "top" ~doc ~man
+
+let link_deps sctx link =
+  let open Memo.O in
+  let* lib_config =
+    let+ ocaml = Super_context.context sctx |> Context.ocaml in
+    ocaml.lib_config
+  in
+  Memo.parallel_map link ~f:(fun t ->
+    Dune_rules.Lib_flags.link_deps sctx t Dune_rules.Link_mode.Byte lib_config)
+  >>| List.concat
+;;
+
+let files_to_load_of_requires sctx requires =
+  let open Memo.O in
+  let* files = link_deps sctx requires in
+  let+ () = Memo.parallel_iter files ~f:Build_system.build_file in
+  List.filter files ~f:(fun p ->
+    let ext = Path.extension p in
+    ext = Ocaml.Mode.compiled_lib_ext Byte || ext = Ocaml.Cm_kind.ext Cmo)
+;;
+
+let term =
+  let+ builder = Common.Builder.term
+  and+ dir = Arg.(value & pos 0 string "" & Arg.info [] ~docv:"DIR")
+  and+ ctx_name = Common.context_arg ~doc:{|Select context where to build/run utop.|} in
+  let common, config = Common.init builder in
+  Scheduler.go_with_rpc_server ~common ~config (fun () ->
+    let open Fiber.O in
+    let* setup = Import.Main.setup () in
+    build_exn (fun () ->
+      let open Memo.O in
+      let* setup = setup in
+      let sctx =
+        Dune_engine.Context_name.Map.find setup.scontexts ctx_name |> Option.value_exn
+      in
+      let context = Super_context.context sctx in
+      let* libs =
+        let dir =
+          let build_dir = Context.build_dir context in
+          Path.Build.relative build_dir (Common.prefix_target common dir)
+        in
+        let* db =
+          let+ scope = Dune_rules.Scope.DB.find_by_dir dir in
+          Dune_rules.Scope.libs scope
+        in
+        (* TODO why don't we read ppx as well?*)
+        Dune_rules.Utop.libs_under_dir sctx ~db ~dir:(Path.build dir)
+      in
+      let* requires =
+        Dune_rules.Resolve.Memo.read_memo (Dune_rules.Lib.closure ~linking:true libs)
+      in
+      let* lib_config =
+        let+ ocaml = Context.ocaml context in
+        ocaml.lib_config
+      in
+      let include_paths =
+        Dune_rules.Lib_flags.L.toplevel_include_paths requires lib_config
+      in
+      let+ files_to_load = files_to_load_of_requires sctx requires in
+      Dune_rules.Toplevel.print_toplevel_init_file
+        { include_paths; files_to_load; uses = []; pp = None; ppx = None; code = [] }))
+;;
+
+let command = Cmd.v info term
+
+module Module = struct
+  let doc = "Print a list of toplevel directives for loading a module into the topevel."
+
+  let man =
+    [ `S "DESCRIPTION"
+    ; `P doc
+    ; `P
+        "The module's source is evaluated in the toplevel without being sealed by the \
+         mli."
+    ; `P
+        {|The output of $(b,dune top) should be evaluated in a toplevel
+          to make the module available there.|}
+    ; `Blocks Common.help_secs
+    ]
+  ;;
+
+  let info = Cmd.info "top-module" ~doc ~man
+
+  let module_directives sctx mod_ =
+    let ctx = Super_context.context sctx in
+    let src = Path.Build.append_source (Context.build_dir ctx) mod_ in
+    let dir = Path.Build.parent_exn src in
+    let filename = Path.Build.basename src in
+    if Filename.extension filename = ""
+    then User_error.raise [ Pp.text "file is missing an extension" ];
+    let open Memo.O in
+    let module_name =
+      let name = Filename.remove_extension filename in
+      Dune_rules.Module_name.of_string_user_error (Loc.none, name) |> User_error.ok_exn
+    in
+    let* expander = Super_context.expander sctx ~dir in
+    let* top_module_info = Dune_rules.Top_module.find_module sctx mod_ in
+    match top_module_info with
+    | None -> User_error.raise [ Pp.text "no module found" ]
+    | Some (_, _, _, Melange _) ->
+      User_error.raise [ Pp.text "Modules belonging to `melange.emit' are not supported" ]
+    | Some (module_, cctx, merlin, _) ->
+      let module Compilation_context = Dune_rules.Compilation_context in
+      let module Obj_dir = Dune_rules.Obj_dir in
+      let module Top_module = Dune_rules.Top_module in
+      let* requires =
+        let* requires = Compilation_context.requires_link cctx in
+        Dune_rules.Resolve.read_memo requires
+      in
+      let private_obj_dir = Top_module.private_obj_dir ctx mod_ in
+      let include_paths =
+        let libs =
+          let lib_config = (Compilation_context.ocaml cctx).lib_config in
+          Dune_rules.Lib_flags.L.toplevel_include_paths requires lib_config
+        in
+        Path.Set.add libs (Path.build (Obj_dir.byte_dir private_obj_dir))
+      in
+      let files_to_load () =
+        let+ libs, modules =
+          Memo.fork_and_join
+            (fun () -> files_to_load_of_requires sctx requires)
+            (fun () ->
+               let cmis () =
+                 let glob =
+                   Dune_engine.File_selector.of_glob
+                     ~dir:(Path.build (Obj_dir.byte_dir private_obj_dir))
+                     (Dune_lang.Glob.of_string_exn Loc.none "*.cmi")
+                 in
+                 let* files = Build_system.eval_pred glob in
+                 Memo.parallel_iter
+                   (Filename_set.to_list files)
+                   ~f:Build_system.build_file
+               in
+               let cmos () =
+                 let obj_dir = Compilation_context.obj_dir cctx in
+                 let dep_graph = (Compilation_context.dep_graphs cctx).impl in
+                 let* modules =
+                   let graph =
+                     Dune_rules.Dep_graph.top_closed_implementations dep_graph [ module_ ]
+                   in
+                   let+ modules, _ = Action_builder.evaluate_and_collect_facts graph in
+                   modules
+                 in
+                 let cmos =
+                   let module Module = Dune_rules.Module in
+                   let module Module_name = Dune_rules.Module_name in
+                   let module_obj_name = Module.obj_name module_ in
+                   List.filter_map modules ~f:(fun m ->
+                     let obj_dir =
+                       if Module_name.Unique.equal module_obj_name (Module.obj_name m)
+                       then private_obj_dir
+                       else obj_dir
+                     in
+                     Obj_dir.Module.cm_file obj_dir m ~kind:(Ocaml Cmo)
+                     |> Option.map ~f:Path.build)
+                 in
+                 let+ (_ : Dep.Facts.t) =
+                   Build_system.build_deps (Dep.Set.of_files cmos)
+                 in
+                 cmos
+               in
+               Memo.fork_and_join_unit cmis cmos)
+        in
+        libs @ modules
+      in
+      let pps () =
+        let module Merlin = Dune_rules.Merlin in
+        let pps = Merlin.pp_config merlin ctx ~expander in
+        let+ pps, _ = Action_builder.evaluate_and_collect_facts pps in
+        let pp = Dune_rules.Module_name.Per_item.get pps module_name in
+        match pp with
+        | None -> None, None
+        | Some pp_flags ->
+          let args = Merlin.Processed.pp_args pp_flags in
+          (match Merlin.Processed.pp_kind pp_flags with
+           | Pp -> Some args, None
+           | Ppx -> None, Some args)
+      in
+      let+ (pp, ppx), files_to_load = Memo.fork_and_join pps files_to_load in
+      let code =
+        let modules = Dune_rules.Compilation_context.modules cctx in
+        let opens_ = Dune_rules.Modules.With_vlib.local_open modules module_ in
+        List.map opens_ ~f:(fun name ->
+          sprintf "open %s" (Dune_rules.Module_name.to_string name))
+      in
+      { Dune_rules.Toplevel.files_to_load; pp; ppx; include_paths; uses = []; code }
+  ;;
+
+  let term =
+    let+ builder = Common.Builder.term
+    and+ module_path =
+      Arg.(
+        required
+        & pos 0 (some string) None
+        & Arg.info [] ~docv:"MODULE" ~doc:"Path to an OCaml module.")
+    and+ ctx_name = Common.context_arg ~doc:{|Select context where to build/run utop.|} in
+    let common, config = Common.init builder in
+    Scheduler.go_with_rpc_server ~common ~config (fun () ->
+      let open Fiber.O in
+      let* setup = Import.Main.setup () in
+      build_exn (fun () ->
+        let open Memo.O in
+        let* setup = setup in
+        let sctx =
+          Dune_engine.Context_name.Map.find setup.scontexts ctx_name |> Option.value_exn
+        in
+        let+ directives =
+          let module_path =
+            if Filename.is_relative module_path
+            then Path.Local.of_string module_path
+            else (
+              let root =
+                (Common.root common).dir
+                |> Path.of_string
+                |> Path.to_absolute_filename
+                |> Path.of_string
+              in
+              match Path.drop_prefix ~prefix:root (Path.of_string module_path) with
+              | Some module_path -> module_path
+              | None ->
+                User_error.raise
+                  [ Pp.text "Module path not a descendent of workspace root." ])
+          in
+          module_directives sctx (Path.Source.of_local module_path)
+        in
+        Dune_rules.Toplevel.print_toplevel_init_file directives))
+  ;;
+end
+
+let module_command = Cmd.v Module.info Module.term

unikernel/duniverse/dune_/bin/ocaml/top.mli

@@ -0,0 +1,4 @@
+open Import
+
+val command : unit Cmd.t
+val module_command : unit Cmd.t

unikernel/duniverse/dune_/bin/ocaml/utop.ml

@@ -0,0 +1,107 @@
+open Import
+module Utop = Dune_rules.Utop
+
+let doc = "Load library in utop."
+
+let man =
+  [ `S "DESCRIPTION"
+  ; `P {|$(b,dune utop DIR) build and run utop toplevel with libraries defined in DIR|}
+  ; `Blocks Common.help_secs
+  ]
+;;
+
+let info = Cmd.info "utop" ~doc ~man
+
+let lock_utop_if_dev_tool_enabled () =
+  match Lazy.force Lock_dev_tool.is_enabled with
+  | false -> Memo.return ()
+  | true -> Lock_dev_tool.lock_dev_tool Utop
+;;
+
+let term =
+  let+ builder = Common.Builder.term
+  and+ dir = Arg.(value & pos 0 string "" & Arg.info [] ~docv:"DIR")
+  and+ ctx_name = Common.context_arg ~doc:{|Select context where to build/run utop.|}
+  and+ args = Arg.(value & pos_right 0 string [] (Arg.info [] ~docv:"ARGS")) in
+  let common, config = Common.init builder in
+  let dir = Common.prefix_target common dir in
+  if not (Path.is_directory (Path.of_string dir))
+  then User_error.raise [ Pp.textf "cannot find directory: %s" (String.maybe_quoted dir) ];
+  let env, utop_path =
+    Scheduler.go_with_rpc_server ~common ~config (fun () ->
+      let open Fiber.O in
+      let* setup = Import.Main.setup () in
+      build_exn (fun () ->
+        let open Memo.O in
+        let* setup = setup in
+        let context = Import.Main.find_context_exn setup ~name:ctx_name in
+        let utop_target_path filename =
+          Path.build
+            (Path.Build.relative
+               (Context.build_dir context)
+               (Filename.concat dir filename))
+        in
+        let utop_exe = utop_target_path Utop.utop_exe in
+        let utop_findlib_conf = utop_target_path Utop.utop_findlib_conf in
+        let* () =
+          (* Calling [Build_system.file_exists] has the side effect of checking
+             and memoizing whether or not the utop dev tool lockdir exists.
+             thus if we generate the lockdir any later than this point, dune
+             will not observe the fact that it now exists. *)
+          lock_utop_if_dev_tool_enabled ()
+        in
+        Build_system.file_exists utop_exe
+        >>= function
+        | false ->
+          User_error.raise
+            [ Pp.textf "no library is defined in %s" (String.maybe_quoted dir) ]
+        | true ->
+          let* () = Build_system.build_file utop_exe in
+          let* utop_dev_tool_lock_dir_exists =
+            Memo.Lazy.force Utop.utop_dev_tool_lock_dir_exists
+          in
+          let* () =
+            if utop_dev_tool_lock_dir_exists
+            then
+              (* Generate the custom findlib.conf file needed when utop is run
+                 as a dev tool. *)
+              Build_system.build_file utop_findlib_conf
+            else Memo.return ()
+          in
+          let sctx = Import.Main.find_scontext_exn setup ~name:ctx_name in
+          let* requires =
+            let dir = Path.Build.relative (Context.build_dir context) dir in
+            Utop.requires_under_dir sctx ~dir
+          in
+          let+ requires = Resolve.read_memo requires
+          and+ lib_config =
+            let+ ocaml = Context.ocaml context in
+            ocaml.lib_config
+          and+ env = Super_context.context_env sctx in
+          let env =
+            Dune_rules.Lib_flags.L.toplevel_ld_paths requires lib_config
+            |> Path.Set.fold
+                 ~f:(fun dir env ->
+                   Env_path.cons ~var:Ocaml.Env.caml_ld_library_path env ~dir)
+                 ~init:env
+          in
+          let env =
+            if utop_dev_tool_lock_dir_exists
+            then
+              (* If there's a utop lockdir then dune will have built utop as a
+                 dev tool. In order for it to run correctly dune needed to
+                 generate a custom findlib.conf that contains the locations of
+                 all of utop's dependencies within the project's _build
+                 directory. Setting this environment variable causes the custom
+                 findlib.conf file to be used instead of the default
+                 findlib.conf. *)
+              Env.add env ~var:"OCAMLFIND_CONF" ~value:(Path.to_string utop_findlib_conf)
+            else env
+          in
+          env, Path.to_string utop_exe))
+  in
+  Hooks.End_of_build.run ();
+  restore_cwd_and_execve (Common.root common) utop_path args env
+;;
+
+let command = Cmd.v info term

unikernel/duniverse/dune_/bin/ocaml/utop.mli

@@ -0,0 +1 @@
+val command : unit Cmdliner.Cmd.t