A hang is a failure the suite never reported

The mutation pass turned up one defect that did not make the suite go
red: a reader branch that forgets to advance reads the same character
for ever, and dune test waits as long as it is left to. In CI that is a
job killed by the runner with nothing named and no output to read.

watchdog.ml puts an alarm on every test binary — generous, because an
alarm that fires on a slow machine is a flake — and a five-second one
around each read in test_flan, where the budget really is small. The
first read that does not return wedges the rest, so a looping reader
costs five seconds and names the row instead of costing eight minutes
or never finishing. Both were watched: the string-escape loop now fails
in five seconds with the case named, and the per-binary backstop was
armed short and observed to fire.

test/dune

@@ -2,8 +2,10 @@
  (names test_flan test_acceptance test_reload test_agent test_session test_dev test_emacs test_repl test_cider)
  ; Explicit because test_sanitize lives in this directory and is not one of
  ; these: two stanzas in one directory have to say which modules are whose.
+ ; watchdog is every binary's clock: a hanging test reports nothing, so each
+ ; of these arms an alarm that turns "for ever" into a failing run.
  (modules test_flan test_acceptance test_reload test_agent test_session
-          test_dev test_emacs test_repl test_cider)
+          test_dev test_emacs test_repl test_cider watchdog)
  (libraries flan unix)
  ; The acceptance programs are part of the test corpus: if the reader, the
  ; parser or the checker regresses on them we want to know here, not at the CLI.
@@ -44,7 +46,7 @@
 ; is the whole point here.
 (executable
  (name test_sanitize)
- (modules test_sanitize)
+ (modules test_sanitize watchdog)
  (libraries flan unix))
 
 (rule

test/test_acceptance.ml

@@ -6,6 +6,10 @@
 
 open Flan
 
+(* The watchdog first: a hang is the one failure mode that reports
+   nothing at all. See watchdog.ml. *)
+let () = Watchdog.arm ~seconds:1200 "test_acceptance"
+
 let failures = ref 0
 
 let scratch = Filename.get_temp_dir_name ()

test/test_agent.ml

@@ -14,6 +14,10 @@
 
 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_agent"
+
 let failures = ref 0
 let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL  " ^ s)) fmt
 

test/test_cider.ml

@@ -12,6 +12,9 @@
    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_cider"
 let () =
   if Sys.command "command -v emacs > /dev/null 2>&1" <> 0 then
     print_endline "cider: skipped (no emacs on PATH)"

test/test_dev.ml

@@ -8,6 +8,10 @@
 
 open Flan
 
+(* The watchdog first: a hang is the one failure mode that reports
+   nothing at all. See watchdog.ml. *)
+let () = Watchdog.arm ~seconds:900 "test_dev"
+
 let failures = ref 0
 let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL  " ^ s)) fmt
 

test/test_emacs.ml

@@ -9,6 +9,9 @@
    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)
 

test/test_flan.ml

@@ -3,6 +3,10 @@
 
 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_flan"
+
 let failures = ref 0
 
 let check name cond =
@@ -16,8 +20,34 @@ let contains hay needle =
   let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in
   n = 0 || go 0
 
+(* Every read in this table runs under a five-second alarm. The reader is the
+   one part of the compiler whose mistakes loop rather than raise — a branch
+   that forgets to advance reads the same character for ever — and a hanging
+   case reports nothing at all. Five seconds is thousands of times what any
+   row here needs; what it buys is that a loop becomes a named failing row and
+   the rest of the table still runs. *)
+(* Once one read has not returned, the reader is looping and every row after
+   it would spend the same five seconds proving the same thing — a hundred
+   rows is eight minutes of that. So the first timeout wedges the rest: they
+   fail immediately and the binary still reports, which is the whole point of
+   the alarm. *)
+let wedged = ref false
+
+let guarded seconds f =
+  if !wedged then raise Watchdog.Timeout
+  else
+    match Watchdog.within seconds f with
+    | x -> x
+    | exception Watchdog.Timeout -> wedged := true; raise Watchdog.Timeout
+
+let read ?(file = "<test>") src =
+  guarded 5 (fun () -> Reader.read_all ~file src)
+
+(* The corpus files, which are larger and are read from disk. *)
+let read_file path = guarded 30 (fun () -> Reader.read_file path)
+
 let reads name src expected =
-  match Reader.read_all ~file:"<test>" src with
+  match read src with
   | forms ->
     let got = String.concat " " (List.map Form.to_string forms) in
     if got <> expected then begin
@@ -29,13 +59,20 @@ let reads name src expected =
     incr failures;
     Printf.printf "FAIL  %s\n        src: %s\n      error: %s: %s\n"
       name src (Loc.to_string loc) msg
+  | exception Watchdog.Timeout ->
+    incr failures;
+    Printf.printf "FAIL  %s\n        src: %s\n      the reader did not return\n"
+      name src
 
 (* [needle] is the point: a read error that fires for the wrong reason is not
    the test passing. Without it "backtick at end of input" would be green even
    if the backtick were still an ordinary symbol character. *)
 let rejects ?needle name src =
-  match Reader.read_all ~file:"<test>" src with
+  match read src with
   | _ -> incr failures; Printf.printf "FAIL  %s: expected a read error\n" name
+  | exception Watchdog.Timeout ->
+    incr failures;
+    Printf.printf "FAIL  %s: the reader did not return\n" name
   | exception Loc.Error (_, msg) ->
     (match needle with
      | Some n when not (contains msg n) ->
@@ -140,7 +177,7 @@ let () =
      `(i ~j ~@k) `(l `(m ~n)) [`o ~p] {:q `r} (f a~b x`y)"
   in
   check "no sigils leak into names"
-    (bad_names (Form.make (Form.List (Reader.read_all ~file:"<test>" corpus))
+    (bad_names (Form.make (Form.List (read corpus))
                   Loc.unknown) = []);
 
   (* ── Errors ────────────────────────────────────────────────────── *)
@@ -158,7 +195,7 @@ let () =
      above rejects the unknown one and not escaping itself. Asserted on the
      string's bytes rather than through [Form.to_string], which escapes them
      again and would compare the source with itself. *)
-  (match Reader.read_all ~file:"<test>" "\"a\\nb\\tc\\\\d\\\"e\\0f\"" with
+  (match read "\"a\\nb\\tc\\\\d\\\"e\\0f\"" with
    | [ { Form.v = Form.Str s; _ } ] ->
      check "known escapes" (s = "a\nb\tc\\d\"e\000f")
    | _ -> check "known escapes: one string" false);
@@ -171,14 +208,14 @@ let () =
   rejects "quasiquote unclosed" "`(a b" ~needle:"unclosed";
 
   (* ── Locations ─────────────────────────────────────────────────── *)
-  (match Reader.read_all ~file:"f.flan" "(a)\n  (b)" with
+  (match read ~file:"f.flan" "(a)\n  (b)" with
    | [ a; b ] ->
      check "loc line 1" (a.loc.line = 1 && a.loc.col = 1);
      check "loc line 2" (b.loc.line = 2 && b.loc.col = 3);
      check "loc file"   (a.loc.file = "f.flan")
    | _ -> check "loc: two forms" false);
 
-  (match Reader.read_all ~file:"f.flan" "(f\n  bad" with
+  (match read ~file:"f.flan" "(f\n  bad" with
    | _ -> check "unclosed reports opening loc" false
    | exception Loc.Error (loc, _) ->
      check "unclosed reports opening loc" (loc.line = 1 && loc.col = 1));
@@ -192,12 +229,12 @@ let () =
 (* ═══ Parse: forms → AST ═══════════════════════════════════════════ *)
 
 let parse1 src =
-  match Reader.read_all ~file:"<test>" src with
+  match read src with
   | [ f ] -> Parse.expr f
   | _ -> failwith "test source must be exactly one form"
 
 let parse_decl src =
-  match Reader.read_all ~file:"<test>" src with
+  match read src with
   | [ f ] -> Parse.decl f
   | _ -> failwith "test source must be exactly one form"
 
@@ -205,7 +242,7 @@ let parse_decl src =
    name with the reason, so a test that only proves *something* failed does not
    observe the rule it is there for. *)
 let parse_rejects ?needle name src =
-  match Reader.read_all ~file:"<test>" src |> Parse.program with
+  match read src |> Parse.program with
   | _ -> incr failures; Printf.printf "FAIL  %s: expected a parse error\n" name
   | exception Loc.Error (_, msg) ->
     (match needle with
@@ -360,7 +397,7 @@ let () =
   (* ── The corpus parses ─────────────────────────────────────────── *)
   List.iter
     (fun path ->
-       match Reader.read_file path |> Parse.program with
+       match read_file path |> Parse.program with
        | _ -> ()
        | exception Loc.Error (loc, msg) ->
          incr failures;
@@ -382,7 +419,9 @@ let () =
    capitalisation — otherwise a body starting with a constructor call gets
    silently eaten as a return type. *)
 
-let program src = Reader.read_all ~file:"<test>" src |> Parse.program
+(* Through [read], so the parser and checker tables are under the reader's
+   alarm too: their sources go through the same reader. *)
+let program src = read src |> Parse.program
 
 let () =
   let open Ast in
@@ -440,6 +479,10 @@ let infers name src expected =
     incr failures;
     Printf.printf "FAIL  %s\n        src: %s\n      error: %s: %s\n"
       name src (Loc.to_string loc) msg
+  | exception Watchdog.Timeout ->
+    incr failures;
+    Printf.printf "FAIL  %s\n        src: %s\n      the reader did not return\n"
+      name src
 
 let accepts name src =
   match checked src with
@@ -448,6 +491,10 @@ let accepts name src =
     incr failures;
     Printf.printf "FAIL  %s\n        src: %s\n      error: %s: %s\n"
       name src (Loc.to_string loc) msg
+  | exception Watchdog.Timeout ->
+    incr failures;
+    Printf.printf "FAIL  %s\n        src: %s\n      the reader did not return\n"
+      name src
 
 (* [needle] pins the *reason* down: a rejection for the wrong reason is not a
    passing test, and the unimplemented-feature errors are the whole point. *)

test/test_reload.ml

@@ -21,6 +21,10 @@
 
 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_reload"
+
 let failures = ref 0
 let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL  " ^ s)) fmt
 

test/test_repl.ml

@@ -16,6 +16,10 @@
 
 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
 

test/test_sanitize.ml

@@ -31,6 +31,10 @@
 
 open Flan
 
+(* The watchdog first: a hang is the one failure mode that reports
+   nothing at all. See watchdog.ml. *)
+let () = Watchdog.arm ~seconds:3600 "test_sanitize"
+
 let failures = ref 0
 let fail fmt =
   Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL  " ^ s)) fmt

test/test_session.ml

@@ -9,6 +9,10 @@
 
 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_session"
+
 let failures = ref 0
 let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL  " ^ s)) fmt
 

test/watchdog.ml

@@ -0,0 +1,62 @@
+(* 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 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