(* 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

(* The watchdog first: a hang is the one failure mode that reports
   nothing at all. See watchdog.ml. *)
let () = Watchdog.arm ~seconds:600 "test_repl"

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

(* 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
       (* Unreachable without WUNTRACED, and here only for exhaustiveness. *)
       | Some (Unix.WSTOPPED n) ->
         Printf.sprintf "stopped on signal %d without binding %s" n path
       | 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 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;
    (* 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
      fail "the daemon %s" !listen_why
    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" "(println \"printed\")" "()";
      (* A macro, over the socket. [Parse.expr] ran no expander at all until
         now, so this was an unknown name — the prelude's macros included,
         which is what said the gap was older than importable macros. [clamp]
         is a prelude [defmacro] and [unless] is the one that stopped being a
         special form, so between them they cover both shapes: one that
         answers a value and one that answers unit. *)
      value "a prelude macro" "(clamp 9 0 3)" "3";
      value "a prelude macro for its effect" "(unless false 1 2)" "()";

      (* 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
      (* A declaration is refused by name. It used to come back as "unknown
         name defvar", which is why the reason asserted here was empty; now
         that an expression expands, a macro can produce one, and the head
         says what it is wherever it appears. *)
      refuses "a declaration" "(defvar nope i64)" "top-level declaration";
      refuses "a declaration inside an expression" "(do 1 (defn f [] i32 1))"
        "top-level declaration";
      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)"