This commit is contained in:
parent
aa2ff7b2f0
commit
2f3113f55d
11742 changed files with 1223940 additions and 0 deletions
101
unikernel/duniverse/dune_/test/expect-tests/dune_rpc_e2e/dune
Normal file
101
unikernel/duniverse/dune_/test/expect-tests/dune_rpc_e2e/dune
Normal file
|
|
@ -0,0 +1,101 @@
|
|||
(env
|
||||
(_
|
||||
(env-vars
|
||||
; We set ocaml to always be colored since it changes the output of
|
||||
; ocamlc error messages. See https://github.com/ocaml/ocaml/issues/14144
|
||||
(OCAML_COLOR always))))
|
||||
|
||||
(library
|
||||
(name dune_rpc_e2e)
|
||||
(modules dune_rpc_e2e)
|
||||
(libraries
|
||||
dune_rpc_client
|
||||
dune_rpc_private
|
||||
dune_util
|
||||
stdune
|
||||
spawn
|
||||
csexp
|
||||
fiber
|
||||
dune_engine
|
||||
dune_rpc_impl
|
||||
csexp_rpc
|
||||
;; This is because of the (implicit_transitive_deps false)
|
||||
;; in dune-project
|
||||
ppx_expect.config
|
||||
ppx_expect.config_types
|
||||
base
|
||||
ppx_inline_test.config)
|
||||
(preprocess
|
||||
(pps ppx_expect)))
|
||||
|
||||
(library
|
||||
(name dune_rpc_diagnostics)
|
||||
(modules dune_rpc_diagnostics)
|
||||
(inline_tests
|
||||
(deps
|
||||
(package dune)))
|
||||
(libraries
|
||||
fiber
|
||||
stdune
|
||||
dune_rpc_client
|
||||
dune_rpc_e2e
|
||||
dune_rpc_private
|
||||
dune_rpc_impl
|
||||
;; This is because of the (implicit_transitive_deps false)
|
||||
;; in dune-project
|
||||
ppx_expect.config
|
||||
ppx_expect.config_types
|
||||
base
|
||||
ppx_inline_test.config)
|
||||
(preprocess
|
||||
(pps ppx_expect)))
|
||||
|
||||
(library
|
||||
(name dune_rpc_registry_test)
|
||||
(modules dune_rpc_registry_test)
|
||||
(inline_tests
|
||||
(deps
|
||||
(package dune)))
|
||||
(libraries
|
||||
dune_rpc_private
|
||||
dune_rpc_e2e
|
||||
dune_engine
|
||||
dune_rpc_impl
|
||||
spawn
|
||||
stdune
|
||||
fiber
|
||||
xdg
|
||||
unix
|
||||
;; This is because of the (implicit_transitive_deps false)
|
||||
;; in dune-project
|
||||
ppx_expect.config
|
||||
ppx_expect.config_types
|
||||
base
|
||||
ppx_inline_test.config)
|
||||
(preprocess
|
||||
(pps ppx_expect)))
|
||||
|
||||
(library
|
||||
(name dune_rpc_jobs_test)
|
||||
(modules dune_rpc_jobs)
|
||||
(inline_tests
|
||||
;; this test is flaky
|
||||
(enabled_if false)
|
||||
(deps
|
||||
(package dune)))
|
||||
(libraries
|
||||
fiber
|
||||
stdune
|
||||
dune_rpc_client
|
||||
dune_rpc_e2e
|
||||
dune_rpc_private
|
||||
dune_rpc_impl
|
||||
unix
|
||||
;; This is because of the (implicit_transitive_deps false)
|
||||
;; in dune-project
|
||||
ppx_expect.config
|
||||
ppx_expect.config_types
|
||||
base
|
||||
ppx_inline_test.config)
|
||||
(preprocess
|
||||
(pps ppx_expect)))
|
||||
|
|
@ -0,0 +1,819 @@
|
|||
open Stdune
|
||||
open Fiber.O
|
||||
module Client = Dune_rpc_client.Client
|
||||
open Dune_rpc_e2e
|
||||
module Dune_rpc = Dune_rpc_private
|
||||
module Sub = Dune_rpc.Sub
|
||||
module Diagnostic = Dune_rpc.Diagnostic
|
||||
module Request = Dune_rpc.Public.Request
|
||||
module Response = Dune_rpc.Response
|
||||
|
||||
let%expect_test "turn on and shutdown" =
|
||||
let test () =
|
||||
with_dune_watch (fun _pid ->
|
||||
run_client (fun client ->
|
||||
let+ () = dune_build client "." in
|
||||
printfn "shutting down"))
|
||||
in
|
||||
run test;
|
||||
[%expect
|
||||
{|
|
||||
Building .
|
||||
Build . succeeded
|
||||
shutting down |}]
|
||||
;;
|
||||
|
||||
let files = List.iter ~f:(fun (f, contents) -> Io.String_path.write_file f contents)
|
||||
|
||||
let on_diagnostic_event diagnostics =
|
||||
let cwd = Sys.getcwd () in
|
||||
let sanitize_path path =
|
||||
match String.drop_prefix path ~prefix:cwd with
|
||||
| None -> path
|
||||
| Some s -> "$CWD" ^ s
|
||||
in
|
||||
let sanitize_pp pp = Pp.verbatim (Format.asprintf "%a@." Pp.to_fmt pp) in
|
||||
let sanitize_loc =
|
||||
let sanitize_position (p : Lexing.position) =
|
||||
{ p with pos_fname = sanitize_path p.pos_fname }
|
||||
in
|
||||
fun (loc : Lexbuf.Loc.t) ->
|
||||
Loc.of_lexbuf_loc loc |> Loc.map_pos ~f:sanitize_position |> Loc.to_lexbuf_loc
|
||||
in
|
||||
(* function to remove remove pp tags and hide junk from paths *)
|
||||
let map_event (d : Diagnostic.Event.t) f : Diagnostic.Event.t =
|
||||
match d with
|
||||
| Remove e -> Remove (f e)
|
||||
| Add e -> Add (f e)
|
||||
in
|
||||
let sanitize (d : Diagnostic.t) =
|
||||
let directory = Option.map d.directory ~f:sanitize_path in
|
||||
let promotion =
|
||||
List.map d.promotion ~f:(fun (p : Diagnostic.Promotion.t) ->
|
||||
let in_build = sanitize_path p.in_build in
|
||||
let in_source = sanitize_path p.in_source in
|
||||
{ Diagnostic.Promotion.in_build; in_source })
|
||||
in
|
||||
let related =
|
||||
List.map d.related ~f:(fun (related : Diagnostic.Related.t) ->
|
||||
let loc = sanitize_loc related.loc in
|
||||
let message = sanitize_pp related.message in
|
||||
{ Diagnostic.Related.message; loc })
|
||||
in
|
||||
{ d with
|
||||
message = sanitize_pp d.message
|
||||
; loc = Option.map d.loc ~f:sanitize_loc
|
||||
; directory
|
||||
; promotion
|
||||
; related
|
||||
}
|
||||
in
|
||||
if List.is_empty diagnostics
|
||||
then print_endline "<no diagnostics>"
|
||||
else
|
||||
List.iter diagnostics ~f:(fun (e : Diagnostic.Event.t) ->
|
||||
(match e with
|
||||
| Remove _ -> ()
|
||||
| Add e ->
|
||||
Diagnostic.promotion e
|
||||
|> List.iter ~f:(fun promotion ->
|
||||
let path = Diagnostic.Promotion.in_build promotion in
|
||||
if not (Sys.file_exists path)
|
||||
then printfn "FAILURE: promotion file %s does not exist" (sanitize_path path)));
|
||||
let e = map_event e sanitize in
|
||||
printfn "%s" (Dyn.to_string (Diagnostic.Event.to_dyn e)))
|
||||
;;
|
||||
|
||||
let setup_diagnostics f =
|
||||
let exec _pid =
|
||||
run_client (fun client ->
|
||||
(* First we test for regular errors *)
|
||||
files [ "dune-project", "(lang dune 3.0)" ];
|
||||
f client)
|
||||
in
|
||||
run (fun () -> with_dune_watch exec)
|
||||
;;
|
||||
|
||||
let poll_exn client decl =
|
||||
let+ poll = Client.poll client decl in
|
||||
match poll with
|
||||
| Ok p -> p
|
||||
| Error e -> raise (Dune_rpc.Version_error.E e)
|
||||
;;
|
||||
|
||||
let print_diagnostics poll =
|
||||
let+ res = Client.Stream.next poll in
|
||||
match res with
|
||||
| None -> printfn "client: no more diagnostics"
|
||||
| Some diag -> on_diagnostic_event diag
|
||||
;;
|
||||
|
||||
let diagnostic_with_build setup target =
|
||||
let exec _pid =
|
||||
run_client (fun client ->
|
||||
(* First we test for regular errors *)
|
||||
files (("dune-project", "(lang dune 3.0)") :: setup);
|
||||
let* () = dune_build client target in
|
||||
let* poll = poll_exn client Dune_rpc.Public.Sub.diagnostic in
|
||||
let* () = print_diagnostics poll in
|
||||
Client.Stream.cancel poll)
|
||||
in
|
||||
run (fun () -> with_dune_watch exec)
|
||||
;;
|
||||
|
||||
let%expect_test "error in dune file" =
|
||||
diagnostic_with_build [ "dune", "(library (name foo))" ] "foo.cma";
|
||||
[%expect
|
||||
{|
|
||||
Building foo.cma
|
||||
Build foo.cma succeeded
|
||||
<no diagnostics> |}]
|
||||
;;
|
||||
|
||||
let%expect_test "related error" =
|
||||
diagnostic_with_build
|
||||
[ "dune", "(library (name foo))"; "foo.mli", "val x : int"; "foo.ml", "let x = true" ]
|
||||
"foo.cma";
|
||||
[%expect
|
||||
{|
|
||||
Building foo.cma
|
||||
Build foo.cma failed
|
||||
[ "Add"
|
||||
; [ [ "directory"; "$CWD" ]
|
||||
; [ "id"; "0" ]
|
||||
; [ "loc"
|
||||
; [ [ "start"
|
||||
; [ [ "pos_bol"; "0" ]
|
||||
; [ "pos_cnum"; "0" ]
|
||||
; [ "pos_fname"; "$CWD/foo.ml" ]
|
||||
; [ "pos_lnum"; "1" ]
|
||||
]
|
||||
]
|
||||
; [ "stop"
|
||||
; [ [ "pos_bol"; "0" ]
|
||||
; [ "pos_cnum"; "0" ]
|
||||
; [ "pos_fname"; "$CWD/foo.ml" ]
|
||||
; [ "pos_lnum"; "1" ]
|
||||
]
|
||||
]
|
||||
]
|
||||
]
|
||||
; [ "message"
|
||||
; [ "Verbatim"
|
||||
; "The implementation foo.ml does not match the interface foo.mli: \n\
|
||||
Values do not match: val x : bool is not included in val x : int\n\
|
||||
The type bool is not compatible with the type int\n\
|
||||
"
|
||||
]
|
||||
]
|
||||
; [ "promotion"; [] ]
|
||||
; [ "related"
|
||||
; [ [ [ "loc"
|
||||
; [ [ "start"
|
||||
; [ [ "pos_bol"; "0" ]
|
||||
; [ "pos_cnum"; "0" ]
|
||||
; [ "pos_fname"; "$CWD/foo.mli" ]
|
||||
; [ "pos_lnum"; "1" ]
|
||||
]
|
||||
]
|
||||
; [ "stop"
|
||||
; [ [ "pos_bol"; "0" ]
|
||||
; [ "pos_cnum"; "11" ]
|
||||
; [ "pos_fname"; "$CWD/foo.mli" ]
|
||||
; [ "pos_lnum"; "1" ]
|
||||
]
|
||||
]
|
||||
]
|
||||
]
|
||||
; [ "message"; [ "Verbatim"; "Expected declaration\n\
|
||||
" ] ]
|
||||
]
|
||||
; [ [ "loc"
|
||||
; [ [ "start"
|
||||
; [ [ "pos_bol"; "0" ]
|
||||
; [ "pos_cnum"; "4" ]
|
||||
; [ "pos_fname"; "$CWD/foo.ml" ]
|
||||
; [ "pos_lnum"; "1" ]
|
||||
]
|
||||
]
|
||||
; [ "stop"
|
||||
; [ [ "pos_bol"; "0" ]
|
||||
; [ "pos_cnum"; "5" ]
|
||||
; [ "pos_fname"; "$CWD/foo.ml" ]
|
||||
; [ "pos_lnum"; "1" ]
|
||||
]
|
||||
]
|
||||
]
|
||||
]
|
||||
; [ "message"; [ "Verbatim"; "Actual declaration\n\
|
||||
" ] ]
|
||||
]
|
||||
]
|
||||
]
|
||||
; [ "severity"; "error" ]
|
||||
; [ "targets"; [] ]
|
||||
]
|
||||
]
|
||||
|}];
|
||||
diagnostic_with_build
|
||||
[ "dune", "(library (name foo)) (executable (name foo))"; "foo.ml", "" ]
|
||||
"@check";
|
||||
[%expect
|
||||
{|
|
||||
Building @check
|
||||
Build @check failed
|
||||
[ "Add"
|
||||
; [ [ "id"; "0" ]
|
||||
; [ "loc"
|
||||
; [ [ "start"
|
||||
; [ [ "pos_bol"; "0" ]
|
||||
; [ "pos_cnum"; "0" ]
|
||||
; [ "pos_fname"; "$CWD/dune" ]
|
||||
; [ "pos_lnum"; "1" ]
|
||||
]
|
||||
]
|
||||
; [ "stop"
|
||||
; [ [ "pos_bol"; "0" ]
|
||||
; [ "pos_cnum"; "20" ]
|
||||
; [ "pos_fname"; "$CWD/dune" ]
|
||||
; [ "pos_lnum"; "1" ]
|
||||
]
|
||||
]
|
||||
]
|
||||
]
|
||||
; [ "message"
|
||||
; [ "Verbatim"; "Module \"Foo\" is used in several stanzas:\n\
|
||||
" ]
|
||||
]
|
||||
; [ "promotion"; [] ]
|
||||
; [ "related"
|
||||
; [ [ [ "loc"
|
||||
; [ [ "start"
|
||||
; [ [ "pos_bol"; "0" ]
|
||||
; [ "pos_cnum"; "21" ]
|
||||
; [ "pos_fname"; "$CWD/dune" ]
|
||||
; [ "pos_lnum"; "1" ]
|
||||
]
|
||||
]
|
||||
; [ "stop"
|
||||
; [ [ "pos_bol"; "0" ]
|
||||
; [ "pos_cnum"; "44" ]
|
||||
; [ "pos_fname"; "$CWD/dune" ]
|
||||
; [ "pos_lnum"; "1" ]
|
||||
]
|
||||
]
|
||||
]
|
||||
]
|
||||
; [ "message"; [ "Verbatim"; "Used in this\n\
|
||||
stanza\n\
|
||||
" ] ]
|
||||
]
|
||||
]
|
||||
]
|
||||
; [ "severity"; "error" ]
|
||||
; [ "targets"; [] ]
|
||||
]
|
||||
] |}]
|
||||
;;
|
||||
|
||||
let%expect_test "promotion" =
|
||||
diagnostic_with_build
|
||||
[ ( "dune"
|
||||
, {|
|
||||
(rule (alias foo) (action (diff x x.gen)))
|
||||
(rule (with-stdout-to x.gen (echo "toto")))
|
||||
|}
|
||||
)
|
||||
; "x", "titi"
|
||||
]
|
||||
"(alias foo)";
|
||||
[%expect
|
||||
{|
|
||||
Building (alias foo)
|
||||
Build (alias foo) failed
|
||||
[ "Add"
|
||||
; [ [ "id"; "0" ]
|
||||
; [ "loc"
|
||||
; [ [ "start"
|
||||
; [ [ "pos_bol"; "0" ]
|
||||
; [ "pos_cnum"; "0" ]
|
||||
; [ "pos_fname"; "$CWD/x" ]
|
||||
; [ "pos_lnum"; "1" ]
|
||||
]
|
||||
]
|
||||
; [ "stop"
|
||||
; [ [ "pos_bol"; "0" ]
|
||||
; [ "pos_cnum"; "0" ]
|
||||
; [ "pos_fname"; "$CWD/x" ]
|
||||
; [ "pos_lnum"; "1" ]
|
||||
]
|
||||
]
|
||||
]
|
||||
]
|
||||
; [ "message"
|
||||
; [ "Verbatim"
|
||||
; "Error: Files _build/default/x and _build/default/x.gen differ.\n\
|
||||
"
|
||||
]
|
||||
]
|
||||
; [ "promotion"
|
||||
; [ [ [ "in_build"; "$CWD/_build/default/x.gen" ]
|
||||
; [ "in_source"; "$CWD/x" ]
|
||||
]
|
||||
]
|
||||
]
|
||||
; [ "related"; [] ]
|
||||
; [ "severity"; "error" ]
|
||||
; [ "targets"; [] ]
|
||||
]
|
||||
] |}]
|
||||
;;
|
||||
|
||||
let%expect_test "optional promotion" =
|
||||
diagnostic_with_build
|
||||
[ ( "dune"
|
||||
, {|
|
||||
(rule
|
||||
(alias foo)
|
||||
(action
|
||||
(progn
|
||||
(with-stdout-to output.expected (echo "foo"))
|
||||
(with-stdout-to output.actual (echo "bar"))
|
||||
(diff? output.expected output.actual))))
|
||||
|}
|
||||
)
|
||||
]
|
||||
"(alias foo)";
|
||||
[%expect
|
||||
{|
|
||||
Building (alias foo)
|
||||
Build (alias foo) failed
|
||||
FAILURE: promotion file $CWD/_build/default/output.actual does not exist
|
||||
[ "Add"
|
||||
; [ [ "id"; "0" ]
|
||||
; [ "loc"
|
||||
; [ [ "start"
|
||||
; [ [ "pos_bol"; "0" ]
|
||||
; [ "pos_cnum"; "0" ]
|
||||
; [ "pos_fname"; "$CWD/output.expected" ]
|
||||
; [ "pos_lnum"; "1" ]
|
||||
]
|
||||
]
|
||||
; [ "stop"
|
||||
; [ [ "pos_bol"; "0" ]
|
||||
; [ "pos_cnum"; "0" ]
|
||||
; [ "pos_fname"; "$CWD/output.expected" ]
|
||||
; [ "pos_lnum"; "1" ]
|
||||
]
|
||||
]
|
||||
]
|
||||
]
|
||||
; [ "message"
|
||||
; [ "Verbatim"
|
||||
; "Error: Files _build/default/output.expected and _build/default/output.actual\n\
|
||||
differ.\n\
|
||||
"
|
||||
]
|
||||
]
|
||||
; [ "promotion"
|
||||
; [ [ [ "in_build"; "$CWD/_build/default/output.actual" ]
|
||||
; [ "in_source"; "$CWD/output.expected" ]
|
||||
]
|
||||
]
|
||||
]
|
||||
; [ "related"; [] ]
|
||||
; [ "severity"; "error" ]
|
||||
; [ "targets"; [] ]
|
||||
]
|
||||
] |}]
|
||||
;;
|
||||
|
||||
let%expect_test "warning detection" =
|
||||
diagnostic_with_build
|
||||
[ "dune", "(executable (flags -w +26) (name foo))"
|
||||
; "foo.ml", "let () = let x = 10 in ()"
|
||||
]
|
||||
"./foo.exe";
|
||||
[%expect
|
||||
{|
|
||||
Building ./foo.exe
|
||||
Build ./foo.exe succeeded
|
||||
<no diagnostics> |}]
|
||||
;;
|
||||
|
||||
let%expect_test "error from user rule" =
|
||||
diagnostic_with_build
|
||||
[ "dune", "(rule (target foo) (action (bash \"echo foobar\")))" ]
|
||||
"./foo";
|
||||
[%expect
|
||||
{|
|
||||
Building ./foo
|
||||
Build ./foo failed
|
||||
[ "Add"
|
||||
; [ [ "id"; "0" ]
|
||||
; [ "loc"
|
||||
; [ [ "start"
|
||||
; [ [ "pos_bol"; "0" ]
|
||||
; [ "pos_cnum"; "0" ]
|
||||
; [ "pos_fname"; "$CWD/dune" ]
|
||||
; [ "pos_lnum"; "1" ]
|
||||
]
|
||||
]
|
||||
; [ "stop"
|
||||
; [ [ "pos_bol"; "0" ]
|
||||
; [ "pos_cnum"; "49" ]
|
||||
; [ "pos_fname"; "$CWD/dune" ]
|
||||
; [ "pos_lnum"; "1" ]
|
||||
]
|
||||
]
|
||||
]
|
||||
]
|
||||
; [ "message"
|
||||
; [ "Verbatim"
|
||||
; "Error: Rule failed to generate the following targets:\n\
|
||||
- foo\n\
|
||||
"
|
||||
]
|
||||
]
|
||||
; [ "promotion"; [] ]
|
||||
; [ "related"; [] ]
|
||||
; [ "severity"; "error" ]
|
||||
; [ "targets"; [] ]
|
||||
]
|
||||
] |}]
|
||||
;;
|
||||
|
||||
let%expect_test "library error location" =
|
||||
diagnostic_with_build
|
||||
[ "dune", "(library (name foo) (libraries fake-library))"; "foo.ml", "" ]
|
||||
"./foo.cma";
|
||||
[%expect
|
||||
{|
|
||||
Building ./foo.cma
|
||||
Build ./foo.cma failed
|
||||
[ "Add"
|
||||
; [ [ "id"; "0" ]
|
||||
; [ "loc"
|
||||
; [ [ "start"
|
||||
; [ [ "pos_bol"; "0" ]
|
||||
; [ "pos_cnum"; "31" ]
|
||||
; [ "pos_fname"; "$CWD/dune" ]
|
||||
; [ "pos_lnum"; "1" ]
|
||||
]
|
||||
]
|
||||
; [ "stop"
|
||||
; [ [ "pos_bol"; "0" ]
|
||||
; [ "pos_cnum"; "43" ]
|
||||
; [ "pos_fname"; "$CWD/dune" ]
|
||||
; [ "pos_lnum"; "1" ]
|
||||
]
|
||||
]
|
||||
]
|
||||
]
|
||||
; [ "message"
|
||||
; [ "Verbatim"; "Error: Library \"fake-library\" not found.\n\
|
||||
" ]
|
||||
]
|
||||
; [ "promotion"; [] ]
|
||||
; [ "related"; [] ]
|
||||
; [ "severity"; "error" ]
|
||||
; [ "targets"; [] ]
|
||||
]
|
||||
] |}]
|
||||
;;
|
||||
|
||||
let%expect_test "create and fix error" =
|
||||
setup_diagnostics (fun client ->
|
||||
files [ "dune", "(executable (name foo))"; "foo.ml", "let () = print_endline 123" ];
|
||||
let* poll = poll_exn client Dune_rpc.Public.Sub.diagnostic in
|
||||
let* () = print_diagnostics poll in
|
||||
[%expect
|
||||
{|
|
||||
<no diagnostics> |}];
|
||||
let* () = dune_build client "./foo.exe" in
|
||||
[%expect
|
||||
{|
|
||||
Building ./foo.exe
|
||||
Build ./foo.exe failed |}];
|
||||
let* () = print_diagnostics poll in
|
||||
[%expect
|
||||
{|
|
||||
[ "Add"
|
||||
; [ [ "directory"; "$CWD" ]
|
||||
; [ "id"; "0" ]
|
||||
; [ "loc"
|
||||
; [ [ "start"
|
||||
; [ [ "pos_bol"; "0" ]
|
||||
; [ "pos_cnum"; "23" ]
|
||||
; [ "pos_fname"; "$CWD/foo.ml" ]
|
||||
; [ "pos_lnum"; "1" ]
|
||||
]
|
||||
]
|
||||
; [ "stop"
|
||||
; [ [ "pos_bol"; "0" ]
|
||||
; [ "pos_cnum"; "26" ]
|
||||
; [ "pos_fname"; "$CWD/foo.ml" ]
|
||||
; [ "pos_lnum"; "1" ]
|
||||
]
|
||||
]
|
||||
]
|
||||
]
|
||||
; [ "message"
|
||||
; [ "Verbatim"
|
||||
; "The constant 123 has type int but an expression was expected of type\n\
|
||||
\ string\n\
|
||||
"
|
||||
]
|
||||
]
|
||||
; [ "promotion"; [] ]
|
||||
; [ "related"; [] ]
|
||||
; [ "severity"; "error" ]
|
||||
; [ "targets"; [] ]
|
||||
]
|
||||
]
|
||||
|}];
|
||||
files [ "foo.ml", "let () = print_endline \"foo\"" ];
|
||||
let* () = dune_build client "./foo.exe" in
|
||||
[%expect
|
||||
{|
|
||||
Building ./foo.exe
|
||||
Build ./foo.exe succeeded |}];
|
||||
let+ () = print_diagnostics poll in
|
||||
[%expect
|
||||
{|
|
||||
[ "Remove"
|
||||
; [ [ "directory"; "$CWD" ]
|
||||
; [ "id"; "0" ]
|
||||
; [ "loc"
|
||||
; [ [ "start"
|
||||
; [ [ "pos_bol"; "0" ]
|
||||
; [ "pos_cnum"; "23" ]
|
||||
; [ "pos_fname"; "$CWD/foo.ml" ]
|
||||
; [ "pos_lnum"; "1" ]
|
||||
]
|
||||
]
|
||||
; [ "stop"
|
||||
; [ [ "pos_bol"; "0" ]
|
||||
; [ "pos_cnum"; "26" ]
|
||||
; [ "pos_fname"; "$CWD/foo.ml" ]
|
||||
; [ "pos_lnum"; "1" ]
|
||||
]
|
||||
]
|
||||
]
|
||||
]
|
||||
; [ "message"
|
||||
; [ "Verbatim"
|
||||
; "The constant 123 has type int but an expression was expected of type\n\
|
||||
\ string\n\
|
||||
"
|
||||
]
|
||||
]
|
||||
; [ "promotion"; [] ]
|
||||
; [ "related"; [] ]
|
||||
; [ "severity"; "error" ]
|
||||
; [ "targets"; [] ]
|
||||
]
|
||||
]
|
||||
|}]);
|
||||
[%expect {| |}]
|
||||
;;
|
||||
|
||||
let request_exn client req n =
|
||||
let* staged = Client.Versioned.prepare_request client req in
|
||||
match staged with
|
||||
| Ok req -> Client.request client req n
|
||||
| Error e -> raise (Dune_rpc.Version_error.E e)
|
||||
;;
|
||||
|
||||
let%expect_test "formatting dune files" =
|
||||
let exec _pid =
|
||||
run_client (fun client ->
|
||||
(* First we test for regular errors *)
|
||||
files [ "dune-project", "(lang dune 3.0)" ];
|
||||
let unformatted = "(\nlibrary (name foo\n))" in
|
||||
printfn "Unformatted:\n%s" unformatted;
|
||||
let run uri what =
|
||||
let+ res =
|
||||
request_exn client Request.format_dune_file (uri, `Contents unformatted)
|
||||
in
|
||||
match res with
|
||||
| Ok s -> printfn "Formatted (%s):\n%s" what s
|
||||
| Error e ->
|
||||
Format.eprintf
|
||||
"Error formatting:@.%s@."
|
||||
(Dyn.to_string (Response.Error.to_dyn e))
|
||||
in
|
||||
let* () = run Dune_rpc.Path.(relative dune_root "dune") "relative" in
|
||||
[%expect
|
||||
{|
|
||||
Unformatted:
|
||||
(
|
||||
library (name foo
|
||||
))
|
||||
Formatted (relative):
|
||||
(library
|
||||
(name foo)) |}];
|
||||
let+ () =
|
||||
run (Dune_rpc.Path.absolute (Filename.concat (Sys.getcwd ()) "dune")) "absolute"
|
||||
in
|
||||
[%expect
|
||||
{|
|
||||
Formatted (absolute):
|
||||
(library
|
||||
(name foo)) |}])
|
||||
in
|
||||
run (fun () -> with_dune_watch exec);
|
||||
[%expect {| |}]
|
||||
;;
|
||||
|
||||
let%expect_test "promoting dune files" =
|
||||
let exec _pid =
|
||||
run_client (fun client ->
|
||||
(* First we test for regular errors *)
|
||||
let fname = "x" in
|
||||
let promoted = "x.gen" in
|
||||
files
|
||||
[ "dune-project", "(lang dune 3.0)"
|
||||
; "x", "titi"
|
||||
; ( "dune"
|
||||
, sprintf
|
||||
{|
|
||||
(rule (alias foo) (action (diff %s %s)))
|
||||
(rule (with-stdout-to %s (echo "toto")))
|
||||
|}
|
||||
fname
|
||||
promoted
|
||||
promoted )
|
||||
];
|
||||
let* () = dune_build client "(alias foo)" in
|
||||
[%expect
|
||||
{|
|
||||
Building (alias foo)
|
||||
Build (alias foo) failed |}];
|
||||
print_endline "attempting to promote";
|
||||
let+ res =
|
||||
request_exn client Request.promote Dune_rpc.Path.(relative dune_root fname)
|
||||
in
|
||||
(match res with
|
||||
| Ok () ->
|
||||
let contents = Io.String_path.read_file fname in
|
||||
printfn "promoted file contents:\n%s" contents
|
||||
| Error e ->
|
||||
Format.eprintf
|
||||
"Error formatting:@.%s@."
|
||||
(Dyn.to_string (Dune_rpc.Response.Error.to_dyn e)));
|
||||
[%expect
|
||||
{|
|
||||
attempting to promote
|
||||
promoted file contents:
|
||||
toto |}])
|
||||
in
|
||||
run (fun () -> with_dune_watch exec);
|
||||
[%expect {| |}]
|
||||
;;
|
||||
|
||||
let%expect_test "multiple errors in one file" =
|
||||
let source =
|
||||
{|
|
||||
module A : sig
|
||||
|
||||
val f : unit
|
||||
[@@alert foo "foobar"]
|
||||
|
||||
end = struct
|
||||
let f = ()
|
||||
end
|
||||
|
||||
let f = A.f
|
||||
let g = A.f
|
||||
|}
|
||||
in
|
||||
setup_diagnostics (fun client ->
|
||||
files [ "dune", "(executable (name foo))"; "foo.ml", source ];
|
||||
let* poll = poll_exn client Dune_rpc.Public.Sub.diagnostic in
|
||||
let* () = print_diagnostics poll in
|
||||
[%expect
|
||||
{|
|
||||
<no diagnostics> |}];
|
||||
let* () = dune_build client "./foo.exe" in
|
||||
[%expect
|
||||
{|
|
||||
Building ./foo.exe
|
||||
Build ./foo.exe failed |}];
|
||||
let+ () = print_diagnostics poll in
|
||||
[%expect
|
||||
{|
|
||||
[ "Add"
|
||||
; [ [ "directory"; "$CWD" ]
|
||||
; [ "id"; "0" ]
|
||||
; [ "loc"
|
||||
; [ [ "start"
|
||||
; [ [ "pos_bol"; "0" ]
|
||||
; [ "pos_cnum"; "8" ]
|
||||
; [ "pos_fname"; "$CWD/foo.ml" ]
|
||||
; [ "pos_lnum"; "11" ]
|
||||
]
|
||||
]
|
||||
; [ "stop"
|
||||
; [ [ "pos_bol"; "0" ]
|
||||
; [ "pos_cnum"; "11" ]
|
||||
; [ "pos_fname"; "$CWD/foo.ml" ]
|
||||
; [ "pos_lnum"; "11" ]
|
||||
]
|
||||
]
|
||||
]
|
||||
]
|
||||
; [ "message"; [ "Verbatim"; "foobar\n\
|
||||
" ] ]
|
||||
; [ "promotion"; [] ]
|
||||
; [ "related"; [] ]
|
||||
; [ "severity"; "error" ]
|
||||
; [ "targets"; [] ]
|
||||
]
|
||||
]
|
||||
[ "Add"
|
||||
; [ [ "directory"; "$CWD" ]
|
||||
; [ "id"; "1" ]
|
||||
; [ "loc"
|
||||
; [ [ "start"
|
||||
; [ [ "pos_bol"; "0" ]
|
||||
; [ "pos_cnum"; "8" ]
|
||||
; [ "pos_fname"; "$CWD/foo.ml" ]
|
||||
; [ "pos_lnum"; "12" ]
|
||||
]
|
||||
]
|
||||
; [ "stop"
|
||||
; [ [ "pos_bol"; "0" ]
|
||||
; [ "pos_cnum"; "11" ]
|
||||
; [ "pos_fname"; "$CWD/foo.ml" ]
|
||||
; [ "pos_lnum"; "12" ]
|
||||
]
|
||||
]
|
||||
]
|
||||
]
|
||||
; [ "message"; [ "Verbatim"; "foobar\n\
|
||||
" ] ]
|
||||
; [ "promotion"; [] ]
|
||||
; [ "related"; [] ]
|
||||
; [ "severity"; "error" ]
|
||||
; [ "targets"; [] ]
|
||||
]
|
||||
]
|
||||
[ "Add"
|
||||
; [ [ "directory"; "$CWD" ]
|
||||
; [ "id"; "2" ]
|
||||
; [ "loc"
|
||||
; [ [ "start"
|
||||
; [ [ "pos_bol"; "0" ]
|
||||
; [ "pos_cnum"; "4" ]
|
||||
; [ "pos_fname"; "$CWD/foo.ml" ]
|
||||
; [ "pos_lnum"; "11" ]
|
||||
]
|
||||
]
|
||||
; [ "stop"
|
||||
; [ [ "pos_bol"; "0" ]
|
||||
; [ "pos_cnum"; "5" ]
|
||||
; [ "pos_fname"; "$CWD/foo.ml" ]
|
||||
; [ "pos_lnum"; "11" ]
|
||||
]
|
||||
]
|
||||
]
|
||||
]
|
||||
; [ "message"; [ "Verbatim"; "unused value f.\n\
|
||||
" ] ]
|
||||
; [ "promotion"; [] ]
|
||||
; [ "related"; [] ]
|
||||
; [ "severity"; "error" ]
|
||||
; [ "targets"; [] ]
|
||||
]
|
||||
]
|
||||
[ "Add"
|
||||
; [ [ "directory"; "$CWD" ]
|
||||
; [ "id"; "3" ]
|
||||
; [ "loc"
|
||||
; [ [ "start"
|
||||
; [ [ "pos_bol"; "0" ]
|
||||
; [ "pos_cnum"; "4" ]
|
||||
; [ "pos_fname"; "$CWD/foo.ml" ]
|
||||
; [ "pos_lnum"; "12" ]
|
||||
]
|
||||
]
|
||||
; [ "stop"
|
||||
; [ [ "pos_bol"; "0" ]
|
||||
; [ "pos_cnum"; "5" ]
|
||||
; [ "pos_fname"; "$CWD/foo.ml" ]
|
||||
; [ "pos_lnum"; "12" ]
|
||||
]
|
||||
]
|
||||
]
|
||||
]
|
||||
; [ "message"; [ "Verbatim"; "unused value g.\n\
|
||||
" ] ]
|
||||
; [ "promotion"; [] ]
|
||||
; [ "related"; [] ]
|
||||
; [ "severity"; "error" ]
|
||||
; [ "targets"; [] ]
|
||||
]
|
||||
] |}]);
|
||||
[%expect {||}]
|
||||
;;
|
||||
|
|
@ -0,0 +1,199 @@
|
|||
open Stdune
|
||||
open Fiber.O
|
||||
module Scheduler = Dune_engine.Scheduler
|
||||
module Dune_rpc = Dune_rpc_private
|
||||
module Request = Dune_rpc.Public.Request
|
||||
module Diagnostic = Dune_rpc.Diagnostic
|
||||
module Client = Dune_rpc_client.Client
|
||||
module Session = Csexp_rpc.Session
|
||||
|
||||
(* enable to debug process stdout/stderr *)
|
||||
let debug = false
|
||||
let () = if debug then Dune_util.Log.init ~file:Stderr ()
|
||||
|
||||
let dune_prog =
|
||||
lazy
|
||||
(let path = Env_path.path Env.initial in
|
||||
Bin.which ~path "dune" |> Option.value_exn |> Path.to_absolute_filename)
|
||||
;;
|
||||
|
||||
let init_chan ~root_dir =
|
||||
let build_dir = Filename.concat root_dir "_build" in
|
||||
let once () =
|
||||
let env = Env.get Env.initial in
|
||||
match Dune_rpc_impl.Where.Where.get ~env ~build_dir with
|
||||
| Error exn -> Exn.raise exn
|
||||
| Ok None -> Fiber.return None
|
||||
| Ok (Some where) ->
|
||||
let+ conn = Client.Connection.connect where in
|
||||
(match conn with
|
||||
| Ok s -> Some s
|
||||
| Error _ -> None)
|
||||
in
|
||||
let rec loop () =
|
||||
let* res = once () in
|
||||
match res with
|
||||
| Some res -> Fiber.return res
|
||||
| None -> Scheduler.sleep ~seconds:0.2 >>= loop
|
||||
in
|
||||
loop ()
|
||||
;;
|
||||
|
||||
let request_exn client witness n =
|
||||
let* staged = Client.Versioned.prepare_request client witness in
|
||||
let staged =
|
||||
match staged with
|
||||
| Ok s -> s
|
||||
| Error e -> raise (Dune_rpc.Version_error.E e)
|
||||
in
|
||||
Client.request client staged n
|
||||
;;
|
||||
|
||||
let notification_exn client witness n =
|
||||
let* staged = Client.Versioned.prepare_notification client witness in
|
||||
let staged =
|
||||
match staged with
|
||||
| Ok s -> s
|
||||
| Error e -> raise (Dune_rpc.Version_error.E e)
|
||||
in
|
||||
Client.notification client staged n
|
||||
;;
|
||||
|
||||
let run_client ?handler f =
|
||||
let* chan = init_chan ~root_dir:"." in
|
||||
let initialize =
|
||||
let id = Dune_rpc.Id.make (Atom "test") in
|
||||
Dune_rpc.Initialize.Request.create ~id
|
||||
in
|
||||
Dune_rpc_impl.Client.client ?handler chan initialize ~f:(fun client ->
|
||||
Fiber.finalize
|
||||
(fun () -> f client)
|
||||
~finally:(fun () ->
|
||||
notification_exn client Dune_rpc.Public.Notification.shutdown ()))
|
||||
;;
|
||||
|
||||
let read_lines in_ =
|
||||
let in_ = Unix.in_channel_of_descr in_ in
|
||||
let rec loop acc =
|
||||
let* res = Scheduler.async (fun () -> input_line in_) in
|
||||
match res with
|
||||
| Ok a -> loop (a :: acc)
|
||||
| Error e ->
|
||||
(match e.exn with
|
||||
| End_of_file -> ()
|
||||
| _ ->
|
||||
Format.eprintf "Error reading channel: %a@.%!" Exn_with_backtrace.pp_uncaught e);
|
||||
Fiber.return (String.concat (List.rev acc) ~sep:"\n")
|
||||
in
|
||||
let+ res = loop [] in
|
||||
close_in_noerr in_;
|
||||
res
|
||||
;;
|
||||
|
||||
let run ?env ~prog ~argv () =
|
||||
let stdout_i, stdout_w = Unix.pipe ~cloexec:true () in
|
||||
let stderr_i, stderr_w = Unix.pipe ~cloexec:true () in
|
||||
let pid =
|
||||
let argv = prog :: argv in
|
||||
let env = Option.map ~f:Spawn.Env.of_list env in
|
||||
Spawn.spawn
|
||||
~prog
|
||||
~argv
|
||||
~stdout:stdout_w
|
||||
~stderr:stderr_w
|
||||
~stdin:(Lazy.force Dev_null.in_)
|
||||
?env
|
||||
()
|
||||
|> Pid.of_int
|
||||
in
|
||||
Unix.close stdout_w;
|
||||
Unix.close stderr_w;
|
||||
( pid
|
||||
, (let+ proc = Scheduler.wait_for_process ~timeout_seconds:3.0 pid in
|
||||
if proc.status <> Unix.WEXITED 0
|
||||
then (
|
||||
let name =
|
||||
sprintf "%s %s" ("$PATH/" ^ Filename.basename prog) (String.concat ~sep:" " argv)
|
||||
in
|
||||
match proc.status with
|
||||
| Unix.WEXITED i -> printfn "%s returned %d" name i
|
||||
| Unix.WSIGNALED i -> printfn "%s received signal %i" name i
|
||||
| _ -> assert false))
|
||||
, read_lines stdout_i
|
||||
, read_lines stderr_i )
|
||||
;;
|
||||
|
||||
let run_server ?(watch_mode_args = [ "--passive-watch-mode" ]) ?env ~root_dir () =
|
||||
run
|
||||
?env
|
||||
~prog:(Lazy.force dune_prog)
|
||||
~argv:([ "build"; "--root"; root_dir ] @ watch_mode_args)
|
||||
()
|
||||
;;
|
||||
|
||||
let dune_build client what =
|
||||
printfn "Building %s" what;
|
||||
let+ res =
|
||||
request_exn client (Dune_rpc.Decl.Request.witness Dune_rpc_impl.Decl.build) [ what ]
|
||||
in
|
||||
match res with
|
||||
| Error e ->
|
||||
Format.eprintf
|
||||
"Error building %s:@.%s@."
|
||||
what
|
||||
(Dyn.to_string (Dune_rpc.Response.Error.to_dyn e))
|
||||
| Ok res ->
|
||||
printfn
|
||||
"Build %s %s"
|
||||
what
|
||||
(match res with
|
||||
| Success -> "succeeded"
|
||||
| Failure _ -> "failed")
|
||||
;;
|
||||
|
||||
let with_dune_watch ?watch_mode_args ?env f =
|
||||
let root_dir = "." in
|
||||
let xdg_runtime_dir = Filename.get_temp_dir_name () in
|
||||
Unix.putenv "XDG_RUNTIME_DIR" xdg_runtime_dir;
|
||||
let pid, run_server, server_stdout, server_stderr =
|
||||
run_server ?watch_mode_args ?env ~root_dir ()
|
||||
in
|
||||
let+ res, (stdout, stderr) =
|
||||
Fiber.fork_and_join
|
||||
(fun () -> Fiber.fork_and_join_unit (fun () -> run_server) (fun () -> f pid))
|
||||
(fun () -> Fiber.fork_and_join (fun () -> server_stdout) (fun () -> server_stderr))
|
||||
in
|
||||
(* We wait until the tests finish to print stdout and stderr for determinism.
|
||||
But this has the disadvantage that the fiber above will not always
|
||||
terminate for failed tests. Thus, the output below will never be shown. *)
|
||||
if debug
|
||||
then (
|
||||
if stdout <> "" then printfn "stdout:\n%s" stdout;
|
||||
if stderr <> "" then printfn "stderr:\n%s" stderr);
|
||||
res
|
||||
;;
|
||||
|
||||
let config =
|
||||
Dune_engine.Clflags.display := Quiet;
|
||||
{ Scheduler.Config.concurrency = 1
|
||||
; stats = None
|
||||
; print_ctrl_c_warning = false
|
||||
; watch_exclusions = []
|
||||
}
|
||||
;;
|
||||
|
||||
let run run =
|
||||
let cwd = Sys.getcwd () in
|
||||
let dir = Temp.create Dir ~prefix:"dune" ~suffix:"rpc_test" in
|
||||
let run () =
|
||||
Fiber.with_error_handler run ~on_error:(fun exn ->
|
||||
Exn_with_backtrace.pp_uncaught Format.err_formatter exn;
|
||||
Format.pp_print_flush Format.err_formatter ();
|
||||
Exn_with_backtrace.reraise exn)
|
||||
in
|
||||
Exn.protect
|
||||
~finally:(fun () -> Sys.chdir cwd)
|
||||
~f:(fun () ->
|
||||
Sys.chdir (Path.to_string dir);
|
||||
Scheduler.Run.go config run ~timeout_seconds:5.0 ~on_event:(fun _ _ -> ()))
|
||||
;;
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
open Stdune
|
||||
|
||||
val with_dune_watch
|
||||
: ?watch_mode_args:string list
|
||||
-> ?env:string list
|
||||
-> (Pid.t -> 'a Fiber.t)
|
||||
-> 'a Fiber.t
|
||||
|
||||
val dune_build : Dune_rpc_client.Client.t -> string -> unit Fiber.t
|
||||
|
||||
val run_client
|
||||
: ?handler:Dune_rpc_client.Client.Handler.t
|
||||
-> (Dune_rpc_client.Client.t -> 'a Fiber.t)
|
||||
-> 'a Fiber.t
|
||||
|
||||
val run : (unit -> 'a Fiber.t) -> 'a
|
||||
|
|
@ -0,0 +1,85 @@
|
|||
open Stdune
|
||||
open Fiber.O
|
||||
open Dune_rpc_e2e
|
||||
module Client = Dune_rpc_client.Client
|
||||
module Dune_rpc = Dune_rpc_private
|
||||
|
||||
include struct
|
||||
open Dune_rpc
|
||||
module Job = Job
|
||||
module Conv = Conv
|
||||
end
|
||||
|
||||
let files = List.iter ~f:(fun (f, contents) -> Io.String_path.write_file f contents)
|
||||
|
||||
let poll_exn client decl =
|
||||
let+ poll = Client.poll client decl in
|
||||
match poll with
|
||||
| Ok p -> p
|
||||
| Error e -> raise (Dune_rpc.Version_error.E e)
|
||||
;;
|
||||
|
||||
let print_job_events poll =
|
||||
let+ res = Client.Stream.next poll in
|
||||
let id_to_string id = Conv.to_sexp Job.Id.sexp id |> Sexp.to_string in
|
||||
match res with
|
||||
| None -> printfn "client: no more diagnostics"
|
||||
| Some job_event_list ->
|
||||
List.iter job_event_list ~f:(fun job_event ->
|
||||
match (job_event : Job.Event.t) with
|
||||
| Start job ->
|
||||
printfn
|
||||
"Start %s %s"
|
||||
(id_to_string job.id)
|
||||
(Format.asprintf "%a" Pp.to_fmt job.description)
|
||||
| Stop id -> printfn "Stop %s" (id_to_string id))
|
||||
;;
|
||||
|
||||
let%expect_test "rpc jobs after rebuild" =
|
||||
let rec wait_for_running_file () =
|
||||
match Unix.stat "_build/default/running" with
|
||||
| _stat -> printfn "Background process is running, let's interrupt it..."
|
||||
| exception Unix.Unix_error (Unix.ENOENT, _, _) ->
|
||||
Unix.sleepf 0.01;
|
||||
wait_for_running_file ()
|
||||
in
|
||||
ignore wait_for_running_file;
|
||||
let exec _pid =
|
||||
run_client (fun client ->
|
||||
let* () =
|
||||
Fiber.return
|
||||
@@ files
|
||||
[ "dune-project", "(lang dune 3.10)"
|
||||
; ( "dune"
|
||||
, {|
|
||||
(rule
|
||||
(target foo)
|
||||
(deps bar)
|
||||
(alias runtest)
|
||||
(action
|
||||
(progn
|
||||
(write-file running "hello")
|
||||
(system "sleep 100")
|
||||
(write-file foo "foo"))))
|
||||
|}
|
||||
)
|
||||
]
|
||||
in
|
||||
let* poll = poll_exn client Dune_rpc.Public.Sub.running_jobs in
|
||||
files [ "bar", "" ];
|
||||
wait_for_running_file ();
|
||||
let* () = print_job_events poll in
|
||||
files [ "bar", "more" ];
|
||||
wait_for_running_file ();
|
||||
let* () = print_job_events poll in
|
||||
Client.Stream.cancel poll)
|
||||
in
|
||||
run (fun () -> with_dune_watch ~watch_mode_args:[ "-w"; "@runtest" ] exec);
|
||||
[%expect
|
||||
{|
|
||||
Background process is running, let's interrupt it...
|
||||
Start 1 _build/default/foo
|
||||
Background process is running, let's interrupt it...
|
||||
Stop 1
|
||||
Start 2 _build/default/foo |}]
|
||||
;;
|
||||
|
|
@ -0,0 +1,110 @@
|
|||
open Stdune
|
||||
open Fiber.O
|
||||
module Where = Dune_rpc_private.Where
|
||||
module Registry = Dune_rpc_private.Registry
|
||||
module Scheduler = Dune_engine.Scheduler
|
||||
module Poll_active = Dune_rpc_impl.Poll_active
|
||||
open Dune_rpc_e2e
|
||||
|
||||
let try_ ~times ~delay_seconds ~f =
|
||||
let rec loop = function
|
||||
| 0 -> Fiber.return None
|
||||
| n ->
|
||||
let* res = f () in
|
||||
(match res with
|
||||
| Some s -> Fiber.return (Some s)
|
||||
| None ->
|
||||
let* () = Scheduler.sleep ~seconds:delay_seconds in
|
||||
loop (n - 1))
|
||||
in
|
||||
loop times
|
||||
;;
|
||||
|
||||
let run =
|
||||
let cwd = Sys.getcwd () in
|
||||
Dune_engine.Clflags.display := Quiet;
|
||||
let config =
|
||||
{ Scheduler.Config.concurrency = 1
|
||||
; stats = None
|
||||
; print_ctrl_c_warning = false
|
||||
; watch_exclusions = []
|
||||
}
|
||||
in
|
||||
fun run ->
|
||||
let dir = Temp.create Dir ~prefix:"dune" ~suffix:"rpc_test" in
|
||||
let run () =
|
||||
Fiber.with_error_handler run ~on_error:(fun exn ->
|
||||
Exn_with_backtrace.pp_uncaught Format.err_formatter exn;
|
||||
Format.pp_print_flush Format.err_formatter ();
|
||||
Exn_with_backtrace.reraise exn)
|
||||
in
|
||||
Exn.protect
|
||||
~finally:(fun () -> Sys.chdir cwd)
|
||||
~f:(fun () ->
|
||||
Sys.chdir (Path.to_string dir);
|
||||
Scheduler.Run.go config run ~timeout_seconds:5.0 ~on_event:(fun _ _ -> ()))
|
||||
;;
|
||||
|
||||
let%expect_test "turn on dune watch and wait until the connection is listed" =
|
||||
let case () =
|
||||
let runtime_dir = "_runtime_dir" in
|
||||
Unix.mkdir runtime_dir 0o777;
|
||||
let xdg_runtime_dir = Filename.concat "." runtime_dir in
|
||||
let config =
|
||||
Registry.Config.create
|
||||
(Xdg.create
|
||||
~env:(function
|
||||
| "XDG_RUNTIME_DIR" -> Some xdg_runtime_dir
|
||||
| _ -> None)
|
||||
())
|
||||
in
|
||||
let poll = Registry.create config in
|
||||
let+ dune =
|
||||
let env =
|
||||
("XDG_RUNTIME_DIR=" ^ xdg_runtime_dir) :: Array.to_list (Unix.environment ())
|
||||
in
|
||||
with_dune_watch ~env (fun pid ->
|
||||
let+ res =
|
||||
try_ ~times:5 ~delay_seconds:0.2 ~f:(fun () ->
|
||||
let+ refresh = Poll_active.poll poll in
|
||||
match refresh with
|
||||
| Error _ -> None
|
||||
| Ok r ->
|
||||
if List.is_non_empty (Registry.Refresh.removed r)
|
||||
then Code_error.raise "removed should be empty" [];
|
||||
(match Registry.Refresh.errored r with
|
||||
| [] -> ()
|
||||
| errors ->
|
||||
List.map errors ~f:(fun (name, exn) -> name, Exn.to_dyn exn)
|
||||
|> Code_error.raise "errored should be empty");
|
||||
(match Registry.Refresh.added r with
|
||||
| [ a ] -> Some a
|
||||
| [] -> None
|
||||
| _ :: _ ->
|
||||
Code_error.raise "added returned more than one dune instance" []))
|
||||
in
|
||||
Unix.kill (Stdune.Pid.to_int pid) Sys.sigint;
|
||||
res)
|
||||
in
|
||||
match dune with
|
||||
| None -> printfn "[FAILURE] unable to find connection"
|
||||
| Some dune ->
|
||||
let root = Registry.Dune.root dune in
|
||||
let where =
|
||||
match Registry.Dune.where dune with
|
||||
| `Ip (host, port) -> `Ip (host, port)
|
||||
| `Unix path ->
|
||||
let cwd = Sys.getcwd () in
|
||||
`Unix
|
||||
(match String.drop_prefix path ~prefix:cwd with
|
||||
| None -> path
|
||||
| Some s -> "$CWD" ^ s)
|
||||
in
|
||||
printfn "[PASS] found %s at %s" root (Where.to_string where)
|
||||
in
|
||||
run case;
|
||||
[%expect
|
||||
{|
|
||||
$PATH/dune build --root . --passive-watch-mode returned 130
|
||||
[PASS] found . at unix:path=%24CWD/_build/.rpc/dune |}]
|
||||
;;
|
||||
Loading…
Add table
Add a link
Reference in a new issue