-
Notifications
You must be signed in to change notification settings - Fork 396
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
refactor(describe): move describe workspace into own file
Signed-off-by: Ali Caglayan <alizter@gmail.com>
- Loading branch information
Showing
3 changed files
with
179 additions
and
172 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,6 @@ | ||
| open Import | ||
|
|
||
| val term : unit Term.t | ||
|
|
||
| (** Dune command that describes the workspace *) | ||
| val command : unit Cmd.t |