From 0070c4fce4d734525684bda05cfe38eab4d0cea0 Mon Sep 17 00:00:00 2001 From: Ali Caglayan Date: Thu, 8 Jun 2023 21:35:56 +0200 Subject: [PATCH] refactor(describe): move describe workspace into own file Signed-off-by: Ali Caglayan --- bin/describe/describe.ml | 174 +--------------------------- bin/describe/describe_workspace.ml | 171 +++++++++++++++++++++++++++ bin/describe/describe_workspace.mli | 6 + 3 files changed, 179 insertions(+), 172 deletions(-) create mode 100644 bin/describe/describe_workspace.ml create mode 100644 bin/describe/describe_workspace.mli diff --git a/bin/describe/describe.ml b/bin/describe/describe.ml index 6df6eda13d5e..5ce6dc7515ae 100644 --- a/bin/describe/describe.ml +++ b/bin/describe/describe.ml @@ -1,175 +1,5 @@ -open Stdune open Import -module Options = struct - type t = Describe_common.options - - let arg_with_deps = - let open Arg in - value & flag - & info [ "with-deps" ] - ~doc:"Whether the dependencies between modules should be printed." - - let arg_with_pps = - let open Arg in - value & flag - & info [ "with-pps" ] - ~doc: - "Whether the dependencies towards ppx-rewriters (that are called at \ - compile time) should be taken into account." - - let arg_sanitize_for_tests = - let open Arg in - value & flag - & info [ "sanitize-for-tests" ] - ~doc: - "Sanitize the absolute paths in workspace items, and the associated \ - UIDs, so that the output is reproducible." - - let arg : t Term.t = - let+ with_deps = arg_with_deps - and+ with_pps = arg_with_pps - and+ sanitize_for_tests_value = arg_sanitize_for_tests in - Describe_common.sanitize_for_tests := sanitize_for_tests_value; - { Describe_common.with_deps; with_pps } -end - -module Lang = struct - type t = Dune_lang.Syntax.Version.t - - let arg_conv = - let parser s = - match Scanf.sscanf s "%u.%u" (fun a b -> (a, b)) with - | Ok t -> Ok t - | Error () -> Error (`Msg "Expected version of the form NNN.NNN.") - in - let printer ppf t = - Stdlib.Format.fprintf ppf "%s" (Dune_lang.Syntax.Version.to_string t) - in - Arg.conv ~docv:"VERSION" (parser, printer) - - let arg : t Term.t = - Term.ret - @@ let+ v = - Arg.( - value - & opt arg_conv (0, 1) - & info [ "lang" ] ~docv:"VERSION" - ~doc:"Behave the same as this version of Dune.") - in - if v = (0, 1) then `Ok v - else - let msg = - let pp = - "Only --lang 0.1 is available at the moment as this command is \ - not yet stabilised. If you would like to release a software that \ - relies on the output of 'dune describe', please open a ticket on \ - https://github.com/ocaml/dune." |> Pp.text - in - Stdlib.Format.asprintf "%a" Pp.to_fmt pp - in - `Error (true, msg) -end - -let print_as_sexp dyn = - let rec dune_lang_of_sexp : Sexp.t -> Dune_lang.t = function - | Atom s -> Dune_lang.atom_or_quoted_string s - | List l -> List (List.map l ~f:dune_lang_of_sexp) - in - let cst = - dyn |> Sexp.of_dyn |> dune_lang_of_sexp - |> Dune_lang.Ast.add_loc ~loc:Loc.none - |> Dune_lang.Cst.concrete - in - let version = Dune_lang.Syntax.greatest_supported_version Stanza.syntax in - Pp.to_fmt Stdlib.Format.std_formatter - (Dune_lang.Format.pp_top_sexps ~version [ cst ]) - -let workspace_cmd_term : unit Term.t = - let+ common = Common.term - and+ what = - Arg.( - value & pos_all string [] - & info [] ~docv:"DIRS" - ~doc: - "prints a description of the workspace's structure. If some \ - directories DIRS are provided, then only those directories of the \ - workspace are considered.") - and+ context_name = Common.context_arg ~doc:"Build context to use." - and+ format = Describe_common.Format.arg - and+ lang = Lang.arg - and+ options = Options.arg in - let config = Common.init common in - let dirs = - let args = "workspace" :: what in - let parse = - Dune_lang.Syntax.set Stanza.syntax (Active lang) - @@ - let open Dune_lang.Decoder in - fields @@ field "workspace" - @@ let+ dirs = repeat relative_file in - (* [None] means that all directories should be accepted, - whereas [Some l] means that only the directories in the - list [l] should be accepted. The checks on whether the - paths exist and whether they are directories are performed - later in the [describe] function. *) - let dirs = if List.is_empty dirs then None else Some dirs in - dirs - in - let ast = - Dune_lang.Ast.add_loc ~loc:Loc.none - (List (List.map args ~f:Dune_lang.atom_or_quoted_string)) - in - Dune_lang.Decoder.parse parse Univ_map.empty ast - in - Scheduler.go ~common ~config @@ fun () -> - let open Fiber.O in - let* setup = Import.Main.setup () in - let* setup = Memo.run setup in - let super_context = Import.Main.find_scontext_exn setup ~name:context_name in - let+ res = - Build_system.run_exn @@ fun () -> - let context = Super_context.context super_context in - let open Memo.O in - let* dirs = - (* prefix directories with the workspace root, so that the - command also works correctly when it is run from a - subdirectory *) - Memo.Option.map dirs - ~f: - (Memo.List.map ~f:(fun dir -> - let p = - Path.Source.(relative root) (Common.prefix_target common dir) - in - let s = Path.source p in - if not @@ Path.exists s then - User_error.raise - [ Pp.textf "No such file or directory: %s" (Path.to_string s) - ]; - if not @@ Path.is_directory s then - User_error.raise - [ Pp.textf "File exists, but is not a directory: %s" - (Path.to_string s) - ]; - Memo.return p)) - in - Describe_common.Crawl.workspace options dirs setup context - >>| Describe_common.Sanitize_for_tests.Workspace.sanitize context - >>| Describe_common.Descr.Workspace.to_dyn options - in - match format with - | Describe_common.Format.Csexp -> Csexp.to_channel stdout (Sexp.of_dyn res) - | Sexp -> print_as_sexp res - -let workspace_cmd = - let doc = - "prints a description of the workspace's structure. If some directories \ - DIRS are provided, then only those directories of the workspace are \ - considered." - in - let info = Cmd.info ~doc "workspace" in - Cmd.v info workspace_cmd_term - let group = let doc = "Describe the workspace." in let man = @@ -189,9 +19,9 @@ let group = ] in let info = Cmd.info "describe" ~doc ~man in - let default = workspace_cmd_term in + let default = Describe_workspace.term in Cmd.group ~default info - [ workspace_cmd + [ Describe_workspace.command ; Describe_external_lib_deps.command ; Describe_opam_files.command ; Describe_pp.command diff --git a/bin/describe/describe_workspace.ml b/bin/describe/describe_workspace.ml new file mode 100644 index 000000000000..6fec4dcad341 --- /dev/null +++ b/bin/describe/describe_workspace.ml @@ -0,0 +1,171 @@ +open Import +open Stdune + +module Options = struct + type t = Describe_common.options + + let arg_with_deps = + let open Arg in + value & flag + & info [ "with-deps" ] + ~doc:"Whether the dependencies between modules should be printed." + + let arg_with_pps = + let open Arg in + value & flag + & info [ "with-pps" ] + ~doc: + "Whether the dependencies towards ppx-rewriters (that are called at \ + compile time) should be taken into account." + + let arg_sanitize_for_tests = + let open Arg in + value & flag + & info [ "sanitize-for-tests" ] + ~doc: + "Sanitize the absolute paths in workspace items, and the associated \ + UIDs, so that the output is reproducible." + + let arg : t Term.t = + let+ with_deps = arg_with_deps + and+ with_pps = arg_with_pps + and+ sanitize_for_tests_value = arg_sanitize_for_tests in + Describe_common.sanitize_for_tests := sanitize_for_tests_value; + { Describe_common.with_deps; with_pps } +end + +module Lang = struct + type t = Dune_lang.Syntax.Version.t + + let arg_conv = + let parser s = + match Scanf.sscanf s "%u.%u" (fun a b -> (a, b)) with + | Ok t -> Ok t + | Error () -> Error (`Msg "Expected version of the form NNN.NNN.") + in + let printer ppf t = + Stdlib.Format.fprintf ppf "%s" (Dune_lang.Syntax.Version.to_string t) + in + Arg.conv ~docv:"VERSION" (parser, printer) + + let arg : t Term.t = + Term.ret + @@ let+ v = + Arg.( + value + & opt arg_conv (0, 1) + & info [ "lang" ] ~docv:"VERSION" + ~doc:"Behave the same as this version of Dune.") + in + if v = (0, 1) then `Ok v + else + let msg = + let pp = + "Only --lang 0.1 is available at the moment as this command is \ + not yet stabilised. If you would like to release a software that \ + relies on the output of 'dune describe', please open a ticket on \ + https://github.com/ocaml/dune." |> Pp.text + in + Stdlib.Format.asprintf "%a" Pp.to_fmt pp + in + `Error (true, msg) +end + +let print_as_sexp dyn = + let rec dune_lang_of_sexp : Sexp.t -> Dune_lang.t = function + | Atom s -> Dune_lang.atom_or_quoted_string s + | List l -> List (List.map l ~f:dune_lang_of_sexp) + in + let cst = + dyn |> Sexp.of_dyn |> dune_lang_of_sexp + |> Dune_lang.Ast.add_loc ~loc:Loc.none + |> Dune_lang.Cst.concrete + in + let version = Dune_lang.Syntax.greatest_supported_version Stanza.syntax in + Pp.to_fmt Stdlib.Format.std_formatter + (Dune_lang.Format.pp_top_sexps ~version [ cst ]) + +let term : unit Term.t = + let+ common = Common.term + and+ what = + Arg.( + value & pos_all string [] + & info [] ~docv:"DIRS" + ~doc: + "prints a description of the workspace's structure. If some \ + directories DIRS are provided, then only those directories of the \ + workspace are considered.") + and+ context_name = Common.context_arg ~doc:"Build context to use." + and+ format = Describe_common.Format.arg + and+ lang = Lang.arg + and+ options = Options.arg in + let config = Common.init common in + let dirs = + let args = "workspace" :: what in + let parse = + Dune_lang.Syntax.set Stanza.syntax (Active lang) + @@ + let open Dune_lang.Decoder in + fields @@ field "workspace" + @@ let+ dirs = repeat relative_file in + (* [None] means that all directories should be accepted, + whereas [Some l] means that only the directories in the + list [l] should be accepted. The checks on whether the + paths exist and whether they are directories are performed + later in the [describe] function. *) + let dirs = if List.is_empty dirs then None else Some dirs in + dirs + in + let ast = + Dune_lang.Ast.add_loc ~loc:Loc.none + (List (List.map args ~f:Dune_lang.atom_or_quoted_string)) + in + Dune_lang.Decoder.parse parse Univ_map.empty ast + in + Scheduler.go ~common ~config @@ fun () -> + let open Fiber.O in + let* setup = Import.Main.setup () in + let* setup = Memo.run setup in + let super_context = Import.Main.find_scontext_exn setup ~name:context_name in + let+ res = + Build_system.run_exn @@ fun () -> + let context = Super_context.context super_context in + let open Memo.O in + let* dirs = + (* prefix directories with the workspace root, so that the + command also works correctly when it is run from a + subdirectory *) + Memo.Option.map dirs + ~f: + (Memo.List.map ~f:(fun dir -> + let p = + Path.Source.(relative root) (Common.prefix_target common dir) + in + let s = Path.source p in + if not @@ Path.exists s then + User_error.raise + [ Pp.textf "No such file or directory: %s" (Path.to_string s) + ]; + if not @@ Path.is_directory s then + User_error.raise + [ Pp.textf "File exists, but is not a directory: %s" + (Path.to_string s) + ]; + Memo.return p)) + in + Describe_common.Crawl.workspace options dirs setup context + >>| Describe_common.Sanitize_for_tests.Workspace.sanitize context + >>| Describe_common.Descr.Workspace.to_dyn options + in + match format with + | Describe_common.Format.Csexp -> Csexp.to_channel stdout (Sexp.of_dyn res) + | Sexp -> print_as_sexp res + +let command = + let doc = + "prints a description of the workspace's structure. If some directories \ + DIRS are provided, then only those directories of the workspace are \ + considered." + in + let info = Cmd.info ~doc "workspace" in + Cmd.v info term diff --git a/bin/describe/describe_workspace.mli b/bin/describe/describe_workspace.mli new file mode 100644 index 000000000000..128952122328 --- /dev/null +++ b/bin/describe/describe_workspace.mli @@ -0,0 +1,6 @@ +open Import + +val term : unit Term.t + +(** Dune command that describes the workspace *) +val command : unit Cmd.t