1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
|
open! Import
module Pkg_dev_tool = Dune_rules.Pkg_dev_tool
let add_dev_tools_to_path env =
List.fold_left Pkg_dev_tool.all ~init:env ~f:(fun acc tool ->
let dir = Pkg_dev_tool.exe_path tool |> Path.Build.parent_exn |> Path.build in
Env_path.cons acc ~dir)
;;
let dev_tool_exe_path dev_tool = Path.build @@ Pkg_dev_tool.exe_path dev_tool
let dev_tool_build_target dev_tool =
Dune_lang.Dep_conf.File
(Dune_lang.String_with_vars.make_text
Loc.none
(Path.to_string (dev_tool_exe_path dev_tool)))
;;
let build_dev_tool_directly common dev_tool =
let open Fiber.O in
let+ result =
Build.run_build_system ~common ~request:(fun _build_system ->
Action_builder.path (dev_tool_exe_path dev_tool))
in
match result with
| Error `Already_reported -> raise Dune_util.Report_error.Already_reported
| Ok () -> ()
;;
let build_dev_tool_via_rpc dev_tool =
let target = dev_tool_build_target dev_tool in
Build.build_via_rpc_server ~print_on_success:false ~targets:[ target ]
;;
let lock_and_build_dev_tool ~common ~config dev_tool =
let open Fiber.O in
match Dune_util.Global_lock.lock ~timeout:None with
| Error _lock_held_by ->
Scheduler.go_without_rpc_server ~common ~config (fun () ->
let* () = Lock_dev_tool.lock_dev_tool dev_tool |> Memo.run in
build_dev_tool_via_rpc dev_tool)
| Ok () ->
Scheduler.go_with_rpc_server ~common ~config (fun () ->
let* () = Lock_dev_tool.lock_dev_tool dev_tool |> Memo.run in
build_dev_tool_directly common dev_tool)
;;
let run_dev_tool workspace_root dev_tool ~args =
let exe_name = Pkg_dev_tool.exe_name dev_tool in
let exe_path_string = Path.to_string (dev_tool_exe_path dev_tool) in
Console.print_user_message
(Dune_rules.Pkg_build_progress.format_user_message
~verb:"Running"
~object_:(User_message.command (String.concat ~sep:" " (exe_name :: args))));
Console.finish ();
let env = add_dev_tools_to_path Env.initial in
restore_cwd_and_execve workspace_root exe_path_string args env
;;
let lock_build_and_run_dev_tool ~common ~config dev_tool ~args =
lock_and_build_dev_tool ~common ~config dev_tool;
run_dev_tool (Common.root common) dev_tool ~args
;;
let which_command dev_tool =
let exe_path = dev_tool_exe_path dev_tool in
let exe_name = Pkg_dev_tool.exe_name dev_tool in
let term =
let+ builder = Common.Builder.term
and+ allow_not_installed =
Arg.(
value
& flag
& info
[ "allow-not-installed" ]
~doc:
(sprintf
"If %s is not installed as a dev tool, still print where it would be \
installed."
exe_name))
in
let _ : Common.t * Dune_config_file.Dune_config.t = Common.init builder in
if allow_not_installed || Path.exists exe_path
then print_endline (Path.to_string exe_path)
else User_error.raise [ Pp.textf "%s is not installed as a dev tool" exe_name ]
in
let info =
let doc =
sprintf
"Prints the path to the %s dev tool executable if it exists, errors out \
otherwise."
exe_name
in
Cmd.info exe_name ~doc
in
Cmd.v info term
;;
let install_command dev_tool =
let exe_name = Pkg_dev_tool.exe_name dev_tool in
let term =
let+ builder = Common.Builder.term in
let common, config = Common.init builder in
lock_and_build_dev_tool ~common ~config dev_tool
in
let info =
let doc = sprintf "Install %s as a dev tool" exe_name in
Cmd.info exe_name ~doc
in
Cmd.v info term
;;
let exec_command dev_tool =
let exe_name = Pkg_dev_tool.exe_name dev_tool in
let term =
let+ builder = Common.Builder.term
and+ args = Arg.(value & pos_all string [] (info [] ~docv:"ARGS")) in
let common, config = Common.init builder in
lock_build_and_run_dev_tool ~common ~config dev_tool ~args
in
let info =
let doc =
sprintf
{|Wrapper for running %s intended to be run automatically
by a text editor. All positional arguments will be passed to the
%s executable (pass flags to %s after the '--'
argument, such as 'dune tools exec %s -- --help').|}
exe_name
exe_name
exe_name
exe_name
in
Cmd.info exe_name ~doc
in
Cmd.v info term
;;
|
