flan/test/test_dev.ml

(* [flan dev]: the daemon an editor talks to (NEXT.md, the dev loop).

   What it adds over [flan reload] is that the session persists between
   evaluations and that the daemon owns the build, so its idea of the running
   process is not a guess. Both are tested here by sending a sequence: a name
   the program was never built with, then a second evaluation that uses it. If
   the session were rebuilt per request the second one would not even check. *)

open Flan

let failures = ref 0
let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL  " ^ s)) fmt

let scratch = Filename.get_temp_dir_name ()
let tmp n = Filename.concat scratch ("flan-devtest-" ^ n)

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

let rec connect ?(ms = 5000) path =
  let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
  match Unix.connect s (Unix.ADDR_UNIX path) with
  | () -> s
  | exception Unix.Unix_error (_, _, _) when ms > 0 ->
    Unix.close s;
    ignore (Unix.select [] [] [] 0.005);
    connect ~ms:(ms - 5) path

(* The program's own output arrives on the replies, not on a file: the daemon
   reads its stdout through a pipe so an editor can see it. Every reply is
   drained into here, which is also what an editor does. *)
let output = Buffer.create 256

let request fd sexp =
  let r = Wire.parse (Wire.send fd sexp; Wire.recv fd) in
  (match Wire.string_field r "output" with
   | Some t -> Buffer.add_string output t
   | None -> ());
  r

let status r =
  match Wire.string_field r "status" with Some s -> s | None -> "<none>"

let () =
  match Sys.command "command -v clang > /dev/null 2>&1 && command -v llc > /dev/null 2>&1" with
  | 0 ->
    let sock = tmp "dev.sock" in
    let out = tmp "prog.out" in
    (try Sys.remove sock with Sys_error _ -> ());
    let fd = Unix.openfile out [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
    (* The daemon is run as a subprocess rather than in-process because that is
       how an editor meets it, and because it launches and owns a program of
       its own. Its child's stdout is what we read the result off. *)
    let flan = "../bin/main.exe" in
    let pid =
      Unix.create_process flan
        [| flan; "dev"; "programs/dev-loop.flan"; "-s"; sock |]
        Unix.stdin fd Unix.stderr
    in
    Unix.close fd;

    if not (await (fun () -> Sys.file_exists sock)) then
      fail "the daemon never listened"
    else begin
      (* The daemon owns the program's lifetime and kills it on [close], so
         every step waits for the program to have got there. "ok" from an eval
         means the module was queued, not that it has been installed. *)
      let c = connect sock in
      (* The daemon owns the program's lifetime and kills it on [close], so
         every step waits for the program to have got there. "ok" from an eval
         means the module was queued, not that it has been installed. Output
         only rides along with a reply, so asking is how it is collected, and
         [describe] is the cheapest question there is. *)
      let lines () =
        List.length (String.split_on_char '\n' (Buffer.contents output)) - 1
      in
      let settle n =
        await (fun () ->
          ignore (request c "(:op \"describe\")");
          lines () >= n)
      in

      (* describe: what the daemon believes about the program it launched. *)
      let r = request c "(:op \"describe\")" in
      if status r <> "ok" then fail "describe: %s" (status r);

      (* [defs] is its own op rather than more fields on [describe], because
         [describe] is what an editor polls to drain the program's output. It
         carries what eldoc, completion and find-definition each need: a kind,
         a signature, and where the name is written where that is knowable.
         An empty location is the honest answer for a global — Tast.global has
         no Loc — and an editor is expected to refuse rather than guess. *)
      let r = request c "(:op \"defs\")" in
      if status r <> "ok" then fail "defs: %s" (status r);
      (match Wire.field r "defs" with
       | Some { Form.v = Form.List entries; _ } ->
         let find name =
           List.find_map
             (fun (e : Form.t) ->
                match e.Form.v with
                | Form.List
                    ({ Form.v = Form.Str n; _ }
                     :: { Form.v = Form.Str kind; _ }
                     :: { Form.v = Form.Str sign; _ }
                     :: { Form.v = Form.Str loc; _ } :: [])
                  when String.equal n name -> Some (kind, sign, loc)
                | _ -> None)
             entries
         in
         (match find "step" with
          | Some ("fn", "step [] i64", loc) when String.length loc > 0 ->
            (* Absolute, because an editor is not in this process's working
               directory and cannot resolve a relative one. *)
            if loc.[0] <> '/' then fail "a fn's location is relative: %s" loc
          | Some (k, s, l) -> fail "step is described as (%s, %s, %s)" k s l
          | None -> fail "defs did not mention step");
         (match find "ticks" with
          | Some ("var", "ticks i64", "") -> ()
          | Some (k, s, l) -> fail "ticks is described as (%s, %s, %s)" k s l
          | None -> fail "defs did not mention ticks");
         (match find "agent/wait-raw" with
          | Some ("extern", _, _) -> ()
          | Some (k, _, _) -> fail "an extern is described as %s" k
          | None -> fail "defs did not mention an imported extern")
       | _ -> fail "defs did not answer with a list");

      (* A form that does not check comes back as an error with a location,
         and must not disturb the session. *)
      let r = request c "(:op \"eval\" :code \"(defn step [] i64 nonsense)\" :file \"/tmp/buf.flan\")" in
      if status r <> "error" then fail "a bad form was accepted";
      (match Wire.string_field r "loc" with
       | Some l when String.length l > 0 -> ()
       | _ -> fail "an error carried no location");

      (* A name the program was never built with, then a second evaluation
         that uses it. The second one only checks at all because the session
         kept the first. *)
      let r =
        request c
          "(:op \"eval\" :code \"(defvar extra i64) (defn step [] i64 (set extra (+ extra 5)) extra)\" :file \"/tmp/buf.flan\")"
      in
      if status r <> "ok" then
        fail "adding a var: %s"
          (Option.value ~default:"" (Wire.string_field r "message"));
      (* Wait for the program to have installed it before sending the next.
         Both queued at once is a legitimate thing for the agent to do — one
         poll installs everything pending — but then only the last is observed
         and the sequencing is not what was tested. *)
      if not (settle 2) then fail "the first reload was never installed";
      let r =
        request c
          "(:op \"eval\" :code \"(defn step [] i64 (set extra (+ extra 100)) extra)\" :file \"/tmp/buf.flan\")"
      in
      if status r <> "ok" then
        fail "reusing a var added earlier: %s"
          (Option.value ~default:"" (Wire.string_field r "message"));

      (* A change the running process cannot be told, refused with the reason
         rather than delivered. *)
      let r = request c "(:op \"eval\" :code \"(defvar ticks i32)\" :file \"/tmp/buf.flan\")" in
      if status r <> "error"
         || not
              (match Wire.string_field r "message" with
               | Some m -> String.length m > 0
               | None -> false)
      then fail "retyping a global was not refused";

      if not (settle 3) then fail "the second reload was never installed";

      (* A restart-case in a body the process was never built with. The frame
         it offers is an alloca in the newly loaded module's text, the call it
         guards goes through the host's cell, and the transfer starts in a
         handler and crosses [probe], which the host was compiled with. None of
         those three meet anywhere else in the tests. *)
      let r =
        request c
          "(:op \"eval\" :code \"(defn step [] i64 (restart-case (do (handler-bind [(Missing [c] (invoke-restart 'use-fallback))] (probe)) 0) (use-fallback [] 777)))\" :file \"/tmp/buf.flan\")"
      in
      if status r <> "ok" then
        fail "a redefinition with a restart-case: %s"
          (Option.value ~default:"" (Wire.string_field r "message"));
      if not (settle 4) then fail "the third reload was never installed";

      (* Expression evaluation, which is a different primitive: no name to
         install a body into, so a thunk runs at a frame boundary and the value
         comes back rendered. The program has stopped reaching frame boundaries
         by now, so this only checks that the types that have no printer say so
         rather than guessing — the live path is test_repl. *)
      let r = request c "(:op \"eval-expr\" :code \"(defvar x i64)\" :file \"/tmp/buf.flan\")" in
      if status r <> "error" then fail "a declaration was accepted as an expression";
      ignore (request c "(:op \"close\")");
      Unix.close c;
      (* Closing the connection ends the program, and its transcript is the
         proof: 1 before any reload, 5 from a body over a var that did not
         exist when it started, 105 from a second body reading the same one,
         and 777 from a restart clause in a third — reached by a transfer that
         started in a handler and crossed a function the host was built with. *)
      ignore (Unix.waitpid [] pid);
      let text = Buffer.contents output in
      let wanted = "1\n5\n105\n777\n" in
      if text <> wanted then
        fail "program transcript\n        got: %S\n     wanted: %S" text wanted
    end;

    List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ sock; out ];
    if !failures = 0 then print_endline "dev: all tests passed"
    else begin
      Printf.printf "\n%d failure(s)\n" !failures;
      exit 1
    end
  | _ -> print_endline "dev: skipped (no clang or llc on PATH)"