142 lines
5 KiB
OCaml
142 lines
5 KiB
OCaml
|
open Import
|
||
|
|
|
||
|
|
let ls_term (fetch_results : Path.Build.t -> string list Action_builder.t) =
|
||
|
|
let+ builder = Common.Builder.term
|
||
|
|
and+ paths = Arg.(value & pos_all string [ "." ] & info [] ~docv:"DIR")
|
||
|
|
and+ context =
|
||
|
|
Common.context_arg ~doc:"The context to look in. Defaults to the default context."
|
||
|
|
in
|
||
|
|
let common, config = Common.init builder in
|
||
|
|
let request (_ : Dune_rules.Main.build_system) =
|
||
|
|
let header = List.length paths > 1 in
|
||
|
|
let open Action_builder.O in
|
||
|
|
let+ paragraphs =
|
||
|
|
Action_builder.List.map paths ~f:(fun path ->
|
||
|
|
(* The user supplied directory *)
|
||
|
|
let dir = Path.of_string path in
|
||
|
|
(* The _build and source tree version of this directory *)
|
||
|
|
let build_dir, src_dir =
|
||
|
|
match (dir : Path.t) with
|
||
|
|
| In_source_tree d ->
|
||
|
|
Path.Build.append_source (Dune_engine.Context_name.build_dir context) d, d
|
||
|
|
| In_build_dir d ->
|
||
|
|
let src_dir =
|
||
|
|
(* We only drop the build context if it is correct. *)
|
||
|
|
match Path.Build.extract_build_context d with
|
||
|
|
| Some (dir_context_name, d) ->
|
||
|
|
if
|
||
|
|
Dune_engine.Context_name.equal
|
||
|
|
context
|
||
|
|
(Dune_engine.Context_name.of_string dir_context_name)
|
||
|
|
then d
|
||
|
|
else
|
||
|
|
User_error.raise
|
||
|
|
[ Pp.textf
|
||
|
|
"Directory %s is not in context %S."
|
||
|
|
(Path.to_string_maybe_quoted dir)
|
||
|
|
(Dune_engine.Context_name.to_string context)
|
||
|
|
]
|
||
|
|
| None -> Code_error.raise "aliases_targets: build dir without context" []
|
||
|
|
in
|
||
|
|
d, src_dir
|
||
|
|
| External _ ->
|
||
|
|
User_error.raise
|
||
|
|
[ Pp.textf
|
||
|
|
"Directories outside of the project are not supported: %s"
|
||
|
|
(Path.to_string_maybe_quoted dir)
|
||
|
|
]
|
||
|
|
in
|
||
|
|
(* Check if the directory exists. *)
|
||
|
|
let* () =
|
||
|
|
Action_builder.of_memo
|
||
|
|
@@
|
||
|
|
let open Memo.O in
|
||
|
|
Source_tree.find_dir src_dir
|
||
|
|
>>= function
|
||
|
|
| Some _ -> Memo.return ()
|
||
|
|
| None ->
|
||
|
|
(* The directory didn't exist. We therefore check if it was a
|
||
|
|
directory target and error for the user accordingly. *)
|
||
|
|
let+ is_dir_target =
|
||
|
|
Load_rules.is_under_directory_target (Path.build build_dir)
|
||
|
|
in
|
||
|
|
if is_dir_target
|
||
|
|
then
|
||
|
|
User_error.raise
|
||
|
|
[ Pp.textf
|
||
|
|
"Directory %s is a directory target. This command does not support \
|
||
|
|
the inspection of directory targets."
|
||
|
|
(Path.to_string dir)
|
||
|
|
]
|
||
|
|
else
|
||
|
|
User_error.raise
|
||
|
|
[ Pp.textf "Directory %s does not exist." (Path.to_string dir) ]
|
||
|
|
in
|
||
|
|
let+ targets = fetch_results build_dir in
|
||
|
|
(* If we are printing multiple directories, we print the directory
|
||
|
|
name as a header. *)
|
||
|
|
(if header then [ Pp.textf "%s:" (Path.to_string dir) ] else [])
|
||
|
|
@ [ Pp.concat_map targets ~f:Pp.text ~sep:Pp.space ]
|
||
|
|
|> Pp.concat ~sep:Pp.space)
|
||
|
|
in
|
||
|
|
Console.print
|
||
|
|
[ Pp.vbox @@ Pp.concat_map ~f:Pp.vbox paragraphs ~sep:(Pp.seq Pp.space Pp.space) ]
|
||
|
|
in
|
||
|
|
Scheduler.go_with_rpc_server ~common ~config
|
||
|
|
@@ fun () ->
|
||
|
|
let open Fiber.O in
|
||
|
|
Build.run_build_system ~common ~request
|
||
|
|
>>| fun (_ : (unit, [ `Already_reported ]) result) -> ()
|
||
|
|
;;
|
||
|
|
|
||
|
|
module Aliases_cmd = struct
|
||
|
|
let fetch_results (dir : Path.Build.t) =
|
||
|
|
let open Action_builder.O in
|
||
|
|
let+ alias_targets =
|
||
|
|
let+ load_dir =
|
||
|
|
Action_builder.of_memo (Load_rules.load_dir ~dir:(Path.build dir))
|
||
|
|
in
|
||
|
|
match load_dir with
|
||
|
|
| Load_rules.Loaded.Build build -> Dune_engine.Alias.Name.Map.keys build.aliases
|
||
|
|
| _ -> []
|
||
|
|
in
|
||
|
|
List.map ~f:Dune_engine.Alias.Name.to_string alias_targets
|
||
|
|
;;
|
||
|
|
|
||
|
|
let term = ls_term fetch_results
|
||
|
|
|
||
|
|
let command =
|
||
|
|
let doc = "Print aliases in a given directory. Works similarly to ls." in
|
||
|
|
Cmd.v (Cmd.info "aliases" ~doc ~envs:Common.envs) term
|
||
|
|
;;
|
||
|
|
end
|
||
|
|
|
||
|
|
module Targets_cmd = struct
|
||
|
|
let fetch_results (dir : Path.Build.t) =
|
||
|
|
let open Action_builder.O in
|
||
|
|
let+ targets =
|
||
|
|
let open Memo.O in
|
||
|
|
Target.all_direct_targets (Some (Path.Build.drop_build_context_exn dir))
|
||
|
|
>>| Path.Build.Map.to_list
|
||
|
|
|> Action_builder.of_memo
|
||
|
|
in
|
||
|
|
List.filter_map targets ~f:(fun (path, kind) ->
|
||
|
|
match Path.Build.equal (Path.Build.parent_exn path) dir with
|
||
|
|
| false -> None
|
||
|
|
| true ->
|
||
|
|
(* directory targets can be distinguied by the trailing path separator
|
||
|
|
*)
|
||
|
|
Some
|
||
|
|
(match kind with
|
||
|
|
| Target.File -> Path.Build.basename path
|
||
|
|
| Directory -> Path.Build.basename path ^ Filename.dir_sep))
|
||
|
|
;;
|
||
|
|
|
||
|
|
let term = ls_term fetch_results
|
||
|
|
|
||
|
|
let command =
|
||
|
|
let doc = "Print targets in a given directory. Works similarly to ls." in
|
||
|
|
Cmd.v (Cmd.info "targets" ~doc ~envs:Common.envs) term
|
||
|
|
;;
|
||
|
|
end
|