flan/test/test_emacs.ml

(* The Emacs client, against a real daemon and a real running program.

   test_dev.ml proves the daemon answers correctly. This proves the elisp
   actually talks to it, which is not the same claim: the framing is in bytes
   and Emacs counts characters, `beginning-of-defun' has to find a Flan
   top-level form through Flan's own syntax table, and a reply is read with
   `read'. A mistake in any of those passes the OCaml test and fails here.

   Skipped, not failed, where there is no emacs — the compiler does not depend
   on one. *)

(* The watchdog first: a hang is the one failure mode that reports
   nothing at all. See watchdog.ml. *)
let () = Watchdog.arm ~seconds:600 "test_emacs"
(* The scratch paths, the poll and the daemon wait are in test_support.ml. The
   long note on what [listening] can and cannot tell apart is there with it. *)
let tmp n = Test_support.tmp "flan-emacs-" n
let await = Test_support.await
let listen_why = Test_support.listen_why
let listening = Test_support.listening

let () =
  let have = Test_support.have in
  if not (have "emacs") then print_endline "emacs: skipped (no emacs on PATH)"
  else if not (have "clang" && have "llc") then
    print_endline "emacs: skipped (no clang or llc on PATH)"
  else begin
    let sock = tmp "dev.sock" and out = tmp "prog.out" and err = tmp "dev.err" in
    List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ sock; out; err ];
    let fd = Unix.openfile out [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
    (* The daemon's stderr to a file rather than inherited: it carries the
       "ready on" line and any OCaml backtrace, and a failure here wants both
       quoted next to the client's complaint rather than interleaved with
       whatever else dune was running. *)
    let efd = Unix.openfile err [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
    let flan = "../bin/main.exe" in
    (* Absolute, because the client starts its own daemon at the end of the run
       and does it from the program's directory rather than from this one. *)
    let flan_abs = try Unix.realpath flan with Unix.Unix_error _ -> flan in
    (* And the program itself, for the same reason: the client starts a daemon
       of its own at the end of the run, and the copy it edits is in a
       temporary directory with no package collections above it. *)
    let program =
      let p = "programs/dev-repl.flan" in
      try Unix.realpath p with Unix.Unix_error _ -> p
    in
    (* [--llvm], and it is not incidental: this suite drives the inspector --
       backtrace, locals, globals -- and those are frames on the dev shadow
       stack, which [lib/x86.ml] does not push. The default backend for [flan
       dev] is x86 now, so a flagless daemon here would answer every one of
       those with the refusal naming this flag, and the client half of the
       break protocol would go untested. The client's own daemon at the end of
       the run asks for it through [flan-daemon-args] for the same reason,
       which is also where that setting is proved to reach a command line. *)
    let pid =
      Unix.create_process flan
        [| flan; "dev"; "programs/dev-repl.flan"; "-s"; sock; "--llvm" |]
        Unix.stdin fd efd
    in
    Unix.close fd;
    Unix.close efd;
    (* Thirty seconds and not the 8s default: this waits on an llc-and-link of
       the whole program, ~0.5s warm and 2s cold, worst measured at 6.8s with
       this suite's other binaries running beside it. The watchdog bounds the
       run; a crash no longer waits for either. *)
    if not (listening ~pid sock) then begin
      print_endline ("FAIL  the daemon " ^ !listen_why);
      (try Unix.kill pid Sys.sigkill with Unix.Unix_error _ -> ());
      exit 1
    end;
    (* A copy, because the test edits the buffer it sends from. Removed first
       and made writable after: the original comes out of a build directory
       read-only, so copying onto a leftover copy would fail and leave the old
       one in place. *)
    let buf = tmp "buf.flan" in
    (try Sys.remove buf with Sys_error _ -> ());
    ignore
      (Sys.command
         (Printf.sprintf "cp %s %s" (Filename.quote "programs/dev-repl.flan")
            (Filename.quote buf)));
    (try Unix.chmod buf 0o644 with Unix.Unix_error _ -> ());
    let code =
      Sys.command
        (Printf.sprintf
           "emacs -Q --batch -L ../../../emacs -l ../../../emacs/test-flan.el \
            -- %s %s %s %s 2>&1"
           (Filename.quote sock) (Filename.quote buf) (Filename.quote flan_abs)
           (Filename.quote program))
    in
    (* The client disconnects at the end, which is what ends the daemon. If it
       did not get that far — because it failed — nothing else will, so it is
       stopped here rather than left waiting on a socket nobody will use.

       The wait *status* is kept, and not thrown away as it used to be, because
       it is the one fact that tells the two failure shapes apart. A daemon
       that exited on its own runs its cleanup and unlinks the socket, and the
       client then says "nothing is listening"; a daemon killed by a signal
       never gets that far, leaves the socket file behind, and the client gets
       an ECONNREFUSED it cannot explain. Two diagnoses of this flake have
       already been wrong for want of this line. *)
    let status = ref None in
    if not (await ~ms:3000 (fun () ->
              match Unix.waitpid [ Unix.WNOHANG ] pid with
              | 0, _ -> false
              | _, st -> status := Some st; true
              | exception Unix.Unix_error _ -> true))
    then begin
      (try Unix.kill pid Sys.sigterm with Unix.Unix_error _ -> ());
      (try ignore (Unix.waitpid [] pid) with Unix.Unix_error _ -> ())
    end;
    let how =
      match !status with
      | Some (Unix.WEXITED n) -> Printf.sprintf "exited with status %d" n
      | Some (Unix.WSIGNALED n) ->
        Printf.sprintf "was killed by %s — nothing ran its cleanup, so \
                        the socket file is stale rather than gone"
          (Test_support.signal_name n)
      | Some (Unix.WSTOPPED n) -> Printf.sprintf "stopped on %s" (Test_support.signal_name n)
      | None -> "was still running when the client finished, and was terminated"
    in
    (* Read before the removal below, because on a failure this is the evidence
       and the removal is what destroyed it last time. *)
    let tail_of path =
      match open_in_bin path with
      | ic ->
        let n = in_channel_length ic in
        let want = min n 4000 in
        seek_in ic (n - want);
        let s = really_input_string ic want in
        close_in ic;
        s
      | exception Sys_error _ -> "<no such file>"
    in
    let sock_left = Sys.file_exists sock in
    let prog_out = if code = 0 then "" else tail_of out in
    let daemon_err = if code = 0 then "" else tail_of err in
    List.iter
      (fun f -> try Sys.remove f with Sys_error _ -> ())
      [ sock; out; err; buf ];
    if code = 0 then print_endline "emacs: all tests passed"
    else begin
      Printf.printf "\nemacs client exited %d\n" code;
      Printf.printf "the daemon %s\n" how;
      Printf.printf "%s was %s after the run\n" sock
        (if sock_left then "still there" else "gone");
      Printf.printf "\n-- the program's own output, last 4k --\n%s\n" prog_out;
      Printf.printf "\n-- the daemon's stderr, last 4k --\n%s\n" daemon_err;
      exit 1
    end
  end