unikernel/duniverse/dune_/bin/describe/aliases_targets.ml

@@ -0,0 +1,141 @@
+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