(* A clock on every test binary, because a green run is not the only outcome
   to plan for.

   The mutation pass that produced NEXT.md's blind-spot list turned up one
   defect that did not make the suite fail — it made it *hang*. A reader loop
   that forgets to advance reads the same character for ever, and every binary
   that reads a .flan file stops there. Nothing prints, nothing exits, and
   [dune test] waits as long as it is left to. In CI that is a job killed by
   the runner's own timeout, with no failing case named and no output to read.

   So: an alarm, at two scales.

   [arm] is the per-binary backstop. It is deliberately generous — test_dev
   launches a daemon and test_acceptance builds for wasm32 — because an alarm
   that fires on a slow machine is a flake, and a flake is how a watchdog gets
   deleted. It is here to turn "for ever" into "fails in ten minutes", not to
   measure anything.

   [within] is the tight one, for a call whose budget really is small: reading
   a few characters of source. It raises [Timeout] rather than exiting, so the
   caller can report one failing row and carry on through the rest of its
   table — a binary that dies on the first hang tells you much less than one
   that finishes and names every case that hung.

   SIGALRM is delivered at OCaml's safepoints, which are inserted at loop
   back-edges and function entries, so a tight loop that allocates nothing is
   still interruptible. *)

exception Timeout

let label = ref "test"
let budget = ref 0
let deadline = ref 0.0

let dying _ =
  Printf.eprintf
    "\nFAIL  %s: no result after %ds — stopped by the test watchdog.\n\
    \      A test that hangs reports nothing at all; this is that outcome\n\
    \      turned into a failing run.\n"
    !label !budget;
  flush stderr;
  (* [exit] rather than [_exit]: the rows that did pass are in stdout's buffer
     and a watchdog that threw them away would be worse than the hang. *)
  exit 2

(* Re-arm the backstop for whatever is left of its budget. One second is the
   floor, because [alarm 0] cancels rather than fires. *)
let backstop () =
  Sys.set_signal Sys.sigalrm (Sys.Signal_handle dying);
  let left = !deadline -. Unix.gettimeofday () in
  ignore (Unix.alarm (max 1 (int_of_float left)))

let arm ?(seconds = 600) name =
  label := name;
  budget := seconds;
  deadline := Unix.gettimeofday () +. float_of_int seconds;
  backstop ()

(* [f] under a tighter alarm, with the backstop restored afterwards however
   [f] left. *)
let within seconds f =
  Sys.set_signal Sys.sigalrm (Sys.Signal_handle (fun _ -> raise Timeout));
  ignore (Unix.alarm seconds);
  Fun.protect ~finally:backstop f