Skip to content

Commit 0070c4f

Browse files
AlizterAlizter
committed
refactor(describe): move describe workspace into own file
Signed-off-by: Ali Caglayan <[email protected]>
1 parent d97b724 commit 0070c4f

File tree

3 files changed

+179
-172
lines changed

3 files changed

+179
-172
lines changed

‎bin/describe/describe.ml‎

Lines changed: 2 additions & 172 deletions
Original file line numberDiff line numberDiff line change
@@ -1,175 +1,5 @@
1-
open Stdune
21
open Import
32

4-
module Options = struct
5-
type t = Describe_common.options
6-
7-
let arg_with_deps =
8-
let open Arg in
9-
value & flag
10-
& info [ "with-deps" ]
11-
~doc:"Whether the dependencies between modules should be printed."
12-
13-
let arg_with_pps =
14-
let open Arg in
15-
value & flag
16-
& info [ "with-pps" ]
17-
~doc:
18-
"Whether the dependencies towards ppx-rewriters (that are called at \
19-
compile time) should be taken into account."
20-
21-
let arg_sanitize_for_tests =
22-
let open Arg in
23-
value & flag
24-
& info [ "sanitize-for-tests" ]
25-
~doc:
26-
"Sanitize the absolute paths in workspace items, and the associated \
27-
UIDs, so that the output is reproducible."
28-
29-
let arg : t Term.t =
30-
let+ with_deps = arg_with_deps
31-
and+ with_pps = arg_with_pps
32-
and+ sanitize_for_tests_value = arg_sanitize_for_tests in
33-
Describe_common.sanitize_for_tests := sanitize_for_tests_value;
34-
{ Describe_common.with_deps; with_pps }
35-
end
36-
37-
module Lang = struct
38-
type t = Dune_lang.Syntax.Version.t
39-
40-
let arg_conv =
41-
let parser s =
42-
match Scanf.sscanf s "%u.%u" (fun a b -> (a, b)) with
43-
| Ok t -> Ok t
44-
| Error () -> Error (`Msg "Expected version of the form NNN.NNN.")
45-
in
46-
let printer ppf t =
47-
Stdlib.Format.fprintf ppf "%s" (Dune_lang.Syntax.Version.to_string t)
48-
in
49-
Arg.conv ~docv:"VERSION" (parser, printer)
50-
51-
let arg : t Term.t =
52-
Term.ret
53-
@@ let+ v =
54-
Arg.(
55-
value
56-
& opt arg_conv (0, 1)
57-
& info [ "lang" ] ~docv:"VERSION"
58-
~doc:"Behave the same as this version of Dune.")
59-
in
60-
if v = (0, 1) then `Ok v
61-
else
62-
let msg =
63-
let pp =
64-
"Only --lang 0.1 is available at the moment as this command is \
65-
not yet stabilised. If you would like to release a software that \
66-
relies on the output of 'dune describe', please open a ticket on \
67-
https://github.com/ocaml/dune." |> Pp.text
68-
in
69-
Stdlib.Format.asprintf "%a" Pp.to_fmt pp
70-
in
71-
`Error (true, msg)
72-
end
73-
74-
let print_as_sexp dyn =
75-
let rec dune_lang_of_sexp : Sexp.t -> Dune_lang.t = function
76-
| Atom s -> Dune_lang.atom_or_quoted_string s
77-
| List l -> List (List.map l ~f:dune_lang_of_sexp)
78-
in
79-
let cst =
80-
dyn |> Sexp.of_dyn |> dune_lang_of_sexp
81-
|> Dune_lang.Ast.add_loc ~loc:Loc.none
82-
|> Dune_lang.Cst.concrete
83-
in
84-
let version = Dune_lang.Syntax.greatest_supported_version Stanza.syntax in
85-
Pp.to_fmt Stdlib.Format.std_formatter
86-
(Dune_lang.Format.pp_top_sexps ~version [ cst ])
87-
88-
let workspace_cmd_term : unit Term.t =
89-
let+ common = Common.term
90-
and+ what =
91-
Arg.(
92-
value & pos_all string []
93-
& info [] ~docv:"DIRS"
94-
~doc:
95-
"prints a description of the workspace's structure. If some \
96-
directories DIRS are provided, then only those directories of the \
97-
workspace are considered.")
98-
and+ context_name = Common.context_arg ~doc:"Build context to use."
99-
and+ format = Describe_common.Format.arg
100-
and+ lang = Lang.arg
101-
and+ options = Options.arg in
102-
let config = Common.init common in
103-
let dirs =
104-
let args = "workspace" :: what in
105-
let parse =
106-
Dune_lang.Syntax.set Stanza.syntax (Active lang)
107-
@@
108-
let open Dune_lang.Decoder in
109-
fields @@ field "workspace"
110-
@@ let+ dirs = repeat relative_file in
111-
(* [None] means that all directories should be accepted,
112-
whereas [Some l] means that only the directories in the
113-
list [l] should be accepted. The checks on whether the
114-
paths exist and whether they are directories are performed
115-
later in the [describe] function. *)
116-
let dirs = if List.is_empty dirs then None else Some dirs in
117-
dirs
118-
in
119-
let ast =
120-
Dune_lang.Ast.add_loc ~loc:Loc.none
121-
(List (List.map args ~f:Dune_lang.atom_or_quoted_string))
122-
in
123-
Dune_lang.Decoder.parse parse Univ_map.empty ast
124-
in
125-
Scheduler.go ~common ~config @@ fun () ->
126-
let open Fiber.O in
127-
let* setup = Import.Main.setup () in
128-
let* setup = Memo.run setup in
129-
let super_context = Import.Main.find_scontext_exn setup ~name:context_name in
130-
let+ res =
131-
Build_system.run_exn @@ fun () ->
132-
let context = Super_context.context super_context in
133-
let open Memo.O in
134-
let* dirs =
135-
(* prefix directories with the workspace root, so that the
136-
command also works correctly when it is run from a
137-
subdirectory *)
138-
Memo.Option.map dirs
139-
~f:
140-
(Memo.List.map ~f:(fun dir ->
141-
let p =
142-
Path.Source.(relative root) (Common.prefix_target common dir)
143-
in
144-
let s = Path.source p in
145-
if not @@ Path.exists s then
146-
User_error.raise
147-
[ Pp.textf "No such file or directory: %s" (Path.to_string s)
148-
];
149-
if not @@ Path.is_directory s then
150-
User_error.raise
151-
[ Pp.textf "File exists, but is not a directory: %s"
152-
(Path.to_string s)
153-
];
154-
Memo.return p))
155-
in
156-
Describe_common.Crawl.workspace options dirs setup context
157-
>>| Describe_common.Sanitize_for_tests.Workspace.sanitize context
158-
>>| Describe_common.Descr.Workspace.to_dyn options
159-
in
160-
match format with
161-
| Describe_common.Format.Csexp -> Csexp.to_channel stdout (Sexp.of_dyn res)
162-
| Sexp -> print_as_sexp res
163-
164-
let workspace_cmd =
165-
let doc =
166-
"prints a description of the workspace's structure. If some directories \
167-
DIRS are provided, then only those directories of the workspace are \
168-
considered."
169-
in
170-
let info = Cmd.info ~doc "workspace" in
171-
Cmd.v info workspace_cmd_term
172-
1733
let group =
1744
let doc = "Describe the workspace." in
1755
let man =
@@ -189,9 +19,9 @@ let group =
18919
]
19020
in
19121
let info = Cmd.info "describe" ~doc ~man in
192-
let default = workspace_cmd_term in
22+
let default = Describe_workspace.term in
19323
Cmd.group ~default info
194-
[ workspace_cmd
24+
[ Describe_workspace.command
19525
; Describe_external_lib_deps.command
19626
; Describe_opam_files.command
19727
; Describe_pp.command

‎bin/describe/describe_workspace.ml‎

Lines changed: 171 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,171 @@
1+
open Import
2+
open Stdune
3+
4+
module Options = struct
5+
type t = Describe_common.options
6+
7+
let arg_with_deps =
8+
let open Arg in
9+
value & flag
10+
& info [ "with-deps" ]
11+
~doc:"Whether the dependencies between modules should be printed."
12+
13+
let arg_with_pps =
14+
let open Arg in
15+
value & flag
16+
& info [ "with-pps" ]
17+
~doc:
18+
"Whether the dependencies towards ppx-rewriters (that are called at \
19+
compile time) should be taken into account."
20+
21+
let arg_sanitize_for_tests =
22+
let open Arg in
23+
value & flag
24+
& info [ "sanitize-for-tests" ]
25+
~doc:
26+
"Sanitize the absolute paths in workspace items, and the associated \
27+
UIDs, so that the output is reproducible."
28+
29+
let arg : t Term.t =
30+
let+ with_deps = arg_with_deps
31+
and+ with_pps = arg_with_pps
32+
and+ sanitize_for_tests_value = arg_sanitize_for_tests in
33+
Describe_common.sanitize_for_tests := sanitize_for_tests_value;
34+
{ Describe_common.with_deps; with_pps }
35+
end
36+
37+
module Lang = struct
38+
type t = Dune_lang.Syntax.Version.t
39+
40+
let arg_conv =
41+
let parser s =
42+
match Scanf.sscanf s "%u.%u" (fun a b -> (a, b)) with
43+
| Ok t -> Ok t
44+
| Error () -> Error (`Msg "Expected version of the form NNN.NNN.")
45+
in
46+
let printer ppf t =
47+
Stdlib.Format.fprintf ppf "%s" (Dune_lang.Syntax.Version.to_string t)
48+
in
49+
Arg.conv ~docv:"VERSION" (parser, printer)
50+
51+
let arg : t Term.t =
52+
Term.ret
53+
@@ let+ v =
54+
Arg.(
55+
value
56+
& opt arg_conv (0, 1)
57+
& info [ "lang" ] ~docv:"VERSION"
58+
~doc:"Behave the same as this version of Dune.")
59+
in
60+
if v = (0, 1) then `Ok v
61+
else
62+
let msg =
63+
let pp =
64+
"Only --lang 0.1 is available at the moment as this command is \
65+
not yet stabilised. If you would like to release a software that \
66+
relies on the output of 'dune describe', please open a ticket on \
67+
https://github.com/ocaml/dune." |> Pp.text
68+
in
69+
Stdlib.Format.asprintf "%a" Pp.to_fmt pp
70+
in
71+
`Error (true, msg)
72+
end
73+
74+
let print_as_sexp dyn =
75+
let rec dune_lang_of_sexp : Sexp.t -> Dune_lang.t = function
76+
| Atom s -> Dune_lang.atom_or_quoted_string s
77+
| List l -> List (List.map l ~f:dune_lang_of_sexp)
78+
in
79+
let cst =
80+
dyn |> Sexp.of_dyn |> dune_lang_of_sexp
81+
|> Dune_lang.Ast.add_loc ~loc:Loc.none
82+
|> Dune_lang.Cst.concrete
83+
in
84+
let version = Dune_lang.Syntax.greatest_supported_version Stanza.syntax in
85+
Pp.to_fmt Stdlib.Format.std_formatter
86+
(Dune_lang.Format.pp_top_sexps ~version [ cst ])
87+
88+
let term : unit Term.t =
89+
let+ common = Common.term
90+
and+ what =
91+
Arg.(
92+
value & pos_all string []
93+
& info [] ~docv:"DIRS"
94+
~doc:
95+
"prints a description of the workspace's structure. If some \
96+
directories DIRS are provided, then only those directories of the \
97+
workspace are considered.")
98+
and+ context_name = Common.context_arg ~doc:"Build context to use."
99+
and+ format = Describe_common.Format.arg
100+
and+ lang = Lang.arg
101+
and+ options = Options.arg in
102+
let config = Common.init common in
103+
let dirs =
104+
let args = "workspace" :: what in
105+
let parse =
106+
Dune_lang.Syntax.set Stanza.syntax (Active lang)
107+
@@
108+
let open Dune_lang.Decoder in
109+
fields @@ field "workspace"
110+
@@ let+ dirs = repeat relative_file in
111+
(* [None] means that all directories should be accepted,
112+
whereas [Some l] means that only the directories in the
113+
list [l] should be accepted. The checks on whether the
114+
paths exist and whether they are directories are performed
115+
later in the [describe] function. *)
116+
let dirs = if List.is_empty dirs then None else Some dirs in
117+
dirs
118+
in
119+
let ast =
120+
Dune_lang.Ast.add_loc ~loc:Loc.none
121+
(List (List.map args ~f:Dune_lang.atom_or_quoted_string))
122+
in
123+
Dune_lang.Decoder.parse parse Univ_map.empty ast
124+
in
125+
Scheduler.go ~common ~config @@ fun () ->
126+
let open Fiber.O in
127+
let* setup = Import.Main.setup () in
128+
let* setup = Memo.run setup in
129+
let super_context = Import.Main.find_scontext_exn setup ~name:context_name in
130+
let+ res =
131+
Build_system.run_exn @@ fun () ->
132+
let context = Super_context.context super_context in
133+
let open Memo.O in
134+
let* dirs =
135+
(* prefix directories with the workspace root, so that the
136+
command also works correctly when it is run from a
137+
subdirectory *)
138+
Memo.Option.map dirs
139+
~f:
140+
(Memo.List.map ~f:(fun dir ->
141+
let p =
142+
Path.Source.(relative root) (Common.prefix_target common dir)
143+
in
144+
let s = Path.source p in
145+
if not @@ Path.exists s then
146+
User_error.raise
147+
[ Pp.textf "No such file or directory: %s" (Path.to_string s)
148+
];
149+
if not @@ Path.is_directory s then
150+
User_error.raise
151+
[ Pp.textf "File exists, but is not a directory: %s"
152+
(Path.to_string s)
153+
];
154+
Memo.return p))
155+
in
156+
Describe_common.Crawl.workspace options dirs setup context
157+
>>| Describe_common.Sanitize_for_tests.Workspace.sanitize context
158+
>>| Describe_common.Descr.Workspace.to_dyn options
159+
in
160+
match format with
161+
| Describe_common.Format.Csexp -> Csexp.to_channel stdout (Sexp.of_dyn res)
162+
| Sexp -> print_as_sexp res
163+
164+
let command =
165+
let doc =
166+
"prints a description of the workspace's structure. If some directories \
167+
DIRS are provided, then only those directories of the workspace are \
168+
considered."
169+
in
170+
let info = Cmd.info ~doc "workspace" in
171+
Cmd.v info term

‎bin/describe/describe_workspace.mli‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,6 @@
1+
open Import
2+
3+
val term : unit Term.t
4+
5+
(** Dune command that describes the workspace *)
6+
val command : unit Cmd.t

0 commit comments

Comments
 (0)