flan/test/test_repl.ml

(* C-x C-e: evaluating an expression inside a program that is running.

   A different primitive from redefining a name, and the difference is the
   whole test: there is no name to install a body into, so the expression is
   compiled into a thunk with nowhere to be called from, the module says "run
   this once", and the agent does — at a frame boundary, on the game thread.

   Nothing is marshalled back. A Flan value carries no header, so nothing at
   run time could say what it is; the compiler knows the type and renders it
   there. That is the layout decision's bill, and it is why only the scalars
   work so far.

   The case that matters most is the same expression evaluated twice with
   different answers: that is what says it read the live process's state rather
   than a copy of it. *)

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-repl-" ^ 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

let rec connect ?(ms = 8000) 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

let request fd sexp = Wire.send fd sexp; Wire.parse (Wire.recv fd)
let field r k = Wire.string_field r k
let status r = match field r "status" with Some s -> s | None -> "<none>"

let quote s =
  let b = Buffer.create (String.length s + 8) in
  Buffer.add_char b '"';
  String.iter
    (fun c ->
       if c = '"' || c = '\\' then Buffer.add_char b '\\';
       Buffer.add_char b c)
    s;
  Buffer.add_char b '"';
  Buffer.contents b

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" 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
    let pid =
      Unix.create_process flan
        [| flan; "dev"; "programs/printers.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
      let c = connect sock in
      let evals code =
        request c
          (Printf.sprintf "(:op \"eval-expr\" :code %s :file \"/tmp/buf.flan\")"
             (quote code))
      in
      let value name code expected =
        let r = evals code in
        match field r "value" with
        | Some v when v = expected -> ()
        | Some v -> fail "%s\n        got: %S\n     wanted: %S" name v expected
        | None ->
          fail "%s: %s" name (Option.value ~default:(status r) (field r "message"))
      in
      value "arithmetic" "(+ 1 2)" "3";
      value "a comparison" "(< 1 2)" "true";
      (* Quoted and escaped, in the runtime: a string whose content is not
         escaped does not round-trip and reads as a framing bug. *)
      value "a string" "\"hi\"" "\"hi\"";
      value "an escaped string" "(.name b)" "\"sandy \\\"quoted\\\"\"";
      (* A defconst: its value is in the program's memory and this reads it. *)
      value "a constant" "step-by" "3";
      (* Rendered in C, because the language's own i64->bytes is signed and
         this would otherwise come back as -1. *)
      value "u64 at its maximum" "big" "18446744073709551615";
      (* A struct, nested, with a fixed array inside it. *)
      value "a struct" "(.pos b)" "(V {:x 1.5 :y 0})";
      value "a nested struct" "b"
        "(Blob {:id 7 :name \"sandy \\\"quoted\\\"\" :pos (V {:x 1.5 :y 0}) :tags [ 0 42 0]})";
      value "a fixed array" "arr" "[ 0 0 9 0]";
      (* A slice's length is not known until it runs, so this one renders
         through a loop rather than by unrolling. *)
      value "a slice" "(slice (.tags b) 0 3)" "[ 0 42 0]";
      (* An enum's members are erased to i32 before the backend sees them, so
         the name is recovered from the checker's table. *)
      value "an enum" "col" ":blue";
      (* A Unit expression is almost always a call made for its effect, so it
         has to be *evaluated* and then reported as (). Emitting the literal
         without running it made the prompt answer while nothing happened. *)
      value "a call made for its effect" "(print-line \"printed\")" "()";

      (* The one that proves it ran inside the process: the program increments
         [ticks] every frame, so two evaluations of it must disagree. A copy
         of the program's state, or a value computed here, would not. *)
      let read () =
        match field (evals "ticks") "value" with
        | Some v -> int_of_string_opt v
        | None -> None
      in
      (match (read (), read ()) with
       | Some a, Some b when b > a -> ()
       | Some a, Some b ->
         fail "ticks read %d then %d — the expression did not see the live \
               program advancing" a b
       | _ -> fail "ticks did not evaluate");

      let refuses name code reason =
        let r = evals code in
        match field r "message" with
        | Some m when
            (let n = String.length reason and h = String.length m in
             let rec go i = i + n <= h && (String.sub m i n = reason || go (i + 1)) in
             go 0) -> ()
        | Some m -> fail "%s said %S, wanted it to mention %S" name m reason
        | None -> fail "%s was accepted" name
      in
      refuses "a declaration" "(defvar nope i64)" "";
      refuses "an unknown name" "no-such-name" "unknown name";

      (* And the session is untouched by all of it: an evaluation is not a
         declaration, so nothing named eval/N accumulates in the program. *)
      let r = request c "(:op \"describe\")" in
      if status r <> "ok" then fail "describe after evaluating: %s" (status r);

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