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"
let scratch = Filename.get_temp_dir_name ()
let tmp n = Filename.concat scratch ("flan-emacs-" ^ n)

let rec await ?(ms = 8000) f =
  if f () then true
  else if ms <= 0 then false
  else begin ignore (Unix.select [] [] [] 0.005); await ~ms:(ms - 5) f end

(* One timer covers two waits here — [flan dev] builds the whole program and
   only then binds — so the failure has to say which of them it was. See
   [listening] in test_dev.ml for the whole of the reasoning; this is the same
   helper, kept here rather than shared because these three files have no
   module between them. Watching the process as well as the socket is what
   makes a crash fail in milliseconds instead of costing the full timeout. *)
let listen_why = ref ""

let listening ?(ms = 30000) ~pid path =
  let died = ref None in
  ignore
    (await ~ms (fun () ->
         Sys.file_exists path
         ||
         match Unix.waitpid [ Unix.WNOHANG ] pid with
         | 0, _ -> false
         | _, st -> died := Some st; true
         | exception Unix.Unix_error _ -> false));
  if Sys.file_exists path then true
  else begin
    listen_why :=
      (match !died with
       | Some (Unix.WEXITED n) ->
         Printf.sprintf "exited with status %d before binding %s" n path
       | Some (Unix.WSIGNALED n) ->
         Printf.sprintf "was killed by signal %d before binding %s" n path
       | Some (Unix.WSTOPPED n) -> Printf.sprintf "stopped on signal %d" n
       | None ->
         Printf.sprintf
           "was still running after %ds without binding %s, so it was the \
            build that did not finish, not the socket"
           (ms / 1000) path);
    false
  end

let () =
  let have cmd = Sys.command (Printf.sprintf "command -v %s > /dev/null 2>&1" cmd) = 0 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" in
    List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ sock; out ];
    let fd = Unix.openfile out [ 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
    let pid =
      Unix.create_process flan
        [| flan; "dev"; "programs/dev-repl.flan"; "-s"; sock |]
        Unix.stdin fd Unix.stderr
    in
    Unix.close fd;
    (* 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-dev.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. *)
    if not (await ~ms:3000 (fun () ->
              match Unix.waitpid [ Unix.WNOHANG ] pid with
              | 0, _ -> false
              | _ -> 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;
    List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ sock; out; buf ];
    if code = 0 then print_endline "emacs: all tests passed"
    else begin
      Printf.printf "\nemacs client exited %d\n" code;
      exit 1
    end
  end