The test binaries share one support module instead of ten forks

# Conflicts:
#	FIX.org

FIX.org

@@ -858,3 +858,16 @@ skipping its stores on a re-run is safe against all of that because the
 pushes take the global's slot address, never its value, and they sit before
 the startup call on both backends — nothing in the bracket depends on an
 initialiser having run.
+
+** bin/main.ml still spells the compile pipeline out by hand
+The test directory's copies of Load → Check → Reach.link now go through
+[Test_support.linked] (test/test_support.ml). bin/main.ml has the same shape
+twice more — :684 and :864, each a load, a check and a [Reach.link] feeding
+[Build.executable] — and they were left alone, because the lane that did this
+was test/-scoped and because they are not quite the same three calls: the CLI
+loads through its own [load] and checks with [Check.program_all] rather than
+[Check.program]. So closing this is not a matter of calling the test module
+from bin/, which would be backwards anyway; it means the pipeline moving into
+lib/ — Build, or a small front-end module beside it — with the two checkers'
+difference made an argument, and bin/ and test_support.ml both calling that.
+Not queued.

test/dune

@@ -3,9 +3,13 @@
  ; 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.
+ ; of these arms an alarm that turns "for ever" into a failing run. test_support
+ ; is the other shared module: the failure counter, the report tail, the poll,
+ ; the daemon wait and the front half of a compile, which the binaries that
+ ; wanted them had each been carrying their own copy of.
  (modules test_flan test_acceptance test_reload test_agent test_session
-          test_dev test_emacs test_repl test_cider test_dyn watchdog)
+          test_dev test_emacs test_repl test_cider test_dyn watchdog
+          test_support)
  (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.
@@ -100,7 +104,7 @@
 ; skips with the reason, so it is green on a machine that has neither.
 (test
  (name test_web)
- (modules test_web)
+ (modules test_web test_support)
  (libraries flan unix)
  (deps
   (glob_files programs/*.flan)
@@ -131,7 +135,7 @@
 ; is the whole point here.
 (executable
  (name test_sanitize)
- (modules test_sanitize watchdog)
+ (modules test_sanitize watchdog test_support)
  (libraries flan unix))
 
 (rule
@@ -177,7 +181,7 @@
 ; all. NEXT.md asked for exactly this.
 (executable
  (name test_valgrind)
- (modules test_valgrind watchdog)
+ (modules test_valgrind watchdog test_support)
  (libraries flan unix str))
 
 (rule

test/test_acceptance.ml

@@ -10,7 +10,7 @@ open Flan
    nothing at all. See watchdog.ml. *)
 let () = Watchdog.arm ~seconds:1200 "test_acceptance"
 
-let failures = ref 0
+let failures = Test_support.failures
 
 (* The tail of this file already exits 1 when [failures] is nonzero, and
    there is no path through this binary that skips it: it is one match on
@@ -40,7 +40,7 @@ let () =
   at_exit (fun () ->
     if !failures > 0 then begin flush_all (); Unix._exit 1 end)
 
-let scratch = Filename.get_temp_dir_name ()
+let scratch = Test_support.scratch
 
 (* Every temporary path below carries the calling process's own pid. Within
    one process that is a constant, so it changes nothing about the existing
@@ -76,23 +76,16 @@ let compile ?(opt = "-O2") ?(checks = true) ?(dev = false) ?(x86 = false) path =
             program are two files and not one built twice over the other. *)
          (if x86 then "-x86" else ""))
   in
-  (* Through [Load], so a program with an (import ...) is buildable here: it
+  (* [Test_support.linked] is the read, the load, the check and the link —
-     brings back the package's C shim and linker arguments as well. *)
+     through [Load], so a program with an (import ...) is buildable here, and
-  let l = Load.program ~file:path (Reader.read_file path) in
+     through [Reach.link], so a package nothing reachable calls into hands
-  let p = Check.program l.Load.decls in
+     over no C and no linker argument. *)
-  (* [Reach.link] decides the link from the program: a package nothing
+  let p, csrcs, lflags = Test_support.linked ~dev path in
-     reachable calls into hands over no C and no linker argument, and its
-     functions are not emitted. *)
-  let p, csrcs, lflags = Reach.link ~dev l p in
   ignore (Build.executable ~opts:{ Build.default with opt; checks; dev; x86 }
             ~csrcs ~lflags p ~out:exe);
   exe
 
-(* No Str, and the reader is hand-written for the same reason. *)
+let contains = Test_support.contains
-let contains hay needle =
-  let n = String.length needle and h = String.length hay in
-  let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in
-  go 0
 
 (* The pool that makes this binary's wall clock survivable. Almost all of the
    112 clang invocations below are independent of one another — different
@@ -2660,9 +2653,7 @@ let () =
       else None
     in
     let wasm_build ?(opt = "-O2") path out =
-      let l = Load.program ~file:path (Reader.read_file path) in
+      let p, csrcs, lflags = Test_support.linked path in
-      let p = Check.program l.Load.decls in
-      let p, csrcs, lflags = Reach.link l p in
       ignore
         (Build.executable
            ~opts:{ Build.default with opt; target = Some "wasm32-wasi" }
@@ -5139,9 +5130,5 @@ level "1"
        been drained, in the order they were submitted in. *)
     Pool.drain_all ();
 
-    if !failures = 0 then print_endline "acceptance: all tests passed"
+    Test_support.report ~label:"acceptance" ()
-    else begin
-      Printf.printf "\n%d failure(s)\n" !failures;
-      exit 1
-    end
   | _ -> print_endline "acceptance: skipped (no clang on PATH)"

test/test_agent.ml

@@ -18,36 +18,21 @@ open Flan
    nothing at all. See watchdog.ml. *)
 let () = Watchdog.arm ~seconds:600 "test_agent"
 
-let failures = ref 0
+(* The counter, the scratch paths, the poll and the connect are in
-let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL  " ^ s)) fmt
+   test_support.ml — the note there on why a retry is narrowed to
+   ECONNREFUSED is this file's own reasoning, moved with the code it explains.
 
-let scratch = Filename.get_temp_dir_name ()
+   Both budgets below are shorter than the shared defaults, and deliberately:
-let tmp name = Filename.concat scratch ("flan-agent-" ^ name)
+   everything this file waits on is a program that has already been built and
-
+   launched, so three seconds is a wait for a bind rather than for a compile,
-(* Poll for a condition rather than sleeping a fixed time: the program has to
+   and the two the connect retries for are the width of the bind/listen race
-   bind its socket before there is anything to connect to, and how long that
+   itself. *)
-   takes is not ours to predict. *)
+let fail fmt = Test_support.fail fmt
-let rec await ?(ms = 3000) f =
+let tmp name = Test_support.tmp "flan-agent-" name
-  if f () then true
+let await ?(ms = 3000) f = Test_support.await ~ms f
-  else if ms <= 0 then false
-  else begin
-    ignore (Unix.select [] [] [] 0.005);
-    await ~ms:(ms - 5) f
-  end
-
-(* The socket file appears at [bind], which is a moment before [listen], so a
-   connect can lose that race and get ECONNREFUSED. Retry rather than sleep. *)
-let rec connect ?(ms = 2000) 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 (Unix.ECONNREFUSED, _, _) when ms > 0 ->
-    Unix.close s;
-    ignore (Unix.select [] [] [] 0.005);
-    connect ~ms:(ms - 5) path
 
 let send path line =
-  let s = connect path in
+  let s = Test_support.connect ~ms:2000 path in
   let msg = line ^ "\n" in
   ignore (Unix.write_substring s msg 0 (String.length msg));
   (* Read to EOF, not once: a reply arrives in several pieces, and closing
@@ -555,9 +540,5 @@ let () =
     List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
       [ exe; so1; so2; sock; out; bsock; bout; bexe; qexe; qso; qsock; qout;
         noinstall; lexe; lsock; lout ];
-    if !failures = 0 then print_endline "agent: all tests passed"
+    Test_support.report ~label:"agent" ()
-    else begin
-      Printf.printf "\n%d failure(s)\n" !failures;
-      exit 1
-    end
   | _ -> print_endline "agent: skipped (no clang or llc on PATH)"

test/test_dev.ml

@@ -12,72 +12,16 @@ open Flan
    nothing at all. See watchdog.ml. *)
 let () = Watchdog.arm ~seconds:900 "test_dev"
 
-let failures = ref 0
+(* The counter, the scratch paths, the poll and the daemon wait are all in
-let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL  " ^ s)) fmt
+   test_support.ml, which is where [listening]'s long note about telling a
-
+   still-building daemon from a dead one now lives too. The watchdog armed
-let scratch = Filename.get_temp_dir_name ()
+   just above is what bounds this particular run. *)
-let tmp n = Filename.concat scratch ("flan-devtest-" ^ n)
+let failures = Test_support.failures
-
+let fail fmt = Test_support.fail fmt
-let rec await ?(ms = 5000) f =
+let tmp n = Test_support.tmp "flan-devtest-" n
-  if f () then true
+let await = Test_support.await
-  else if ms <= 0 then false
+let listen_why = Test_support.listen_why
-  else begin ignore (Unix.select [] [] [] 0.005); await ~ms:(ms - 5) f end
+let listening = Test_support.listening
-
-(* Waiting for a daemon to listen is waiting for two different things with one
-   timer: [flan dev] compiles the whole program first, and only then binds. The
-   old message, "the daemon never listened", named the second and was almost
-   always the first — which is a wrong diagnosis, and a wrong diagnosis costs
-   more than no message at all.
-
-   So this says which. It cannot separate the two waits without a signal from
-   [flan dev] that the build is done (see NEXT.md), but it can separate the two
-   *failures*, and that is what actually gets read: a daemon still running when
-   the timer expires was building, and a daemon that is gone bound nothing
-   because it died. The second no longer costs the whole timeout either —
-   the poll watches the process as well as the socket, so a crash fails in
-   milliseconds instead of in half a minute, which is the part that makes a
-   suite worth trusting.
-
-   Thirty seconds, down from a minute, because the object cache is durable now
-   (Build.cachedir) and the build this waits on is warm: 0.48s idle against
-   2.0s cold, and the worst ever measured under dune's own parallelism was
-   6.8s — cold. The watchdog at 900s is still what bounds the run.
-
-   [!listen_why] carries the reason to the caller so each site can keep its own
-   name for its daemon. One ref is enough: this file is single-threaded and the
-   next thing after a failed wait is always the report of it. *)
-let listen_why = ref ""
-
-let listening ?(ms = 30000) ~pid path =
-  let died = ref None in
-  ignore
-    (await ~ms (fun () ->
-         Sys.file_exists path
-         ||
-         (* Reaped only once it is already gone, and only on the path that ends
-            in a failure, so a teardown's own [waitpid] is unaffected. *)
-         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
 
 (* ── Three states, without a program to be in them ──────────────────── *)
 
@@ -150,14 +94,7 @@ let () =
     (Dev.orphaned ~grace:0. ~served:true ~idle:10_000. Dev.Parked)
     false
 
-let rec connect ?(ms = 5000) path =
+let connect = Test_support.connect
-  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
@@ -174,13 +111,7 @@ let request fd sexp =
 let status r =
   match Wire.string_field r "status" with Some s -> s | None -> "<none>"
 
-let contains_sub hay needle =
+let contains_sub = Test_support.contains
-  let n = String.length needle in
-  let rec go i =
-    i + n <= String.length hay
-    && (String.equal (String.sub hay i n) needle || go (i + 1))
-  in
-  go 0
 
 (* ── Whose fault a full reload ring is ──────────────────────────────── *)
 
@@ -2668,11 +2599,7 @@ let () =
       in
       let text r = Option.value ~default:"" (Wire.string_field r "text") in
       let basis r = Option.value ~default:"" (Wire.string_field r "basis") in
-      let has hay needle =
+      let has = contains_sub in
-        let n = String.length needle and h = String.length hay in
-        let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in
-        n > 0 && go 0
-      in
       let have_objdump =
         Sys.command "command -v objdump > /dev/null 2>&1" = 0
       in
@@ -2894,11 +2821,7 @@ let () =
     end
     else begin
       let c = connect ssock in
-      let has hay needle =
+      let has = contains_sub in
-        let n = String.length needle and h = String.length hay in
-        let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in
-        n > 0 && go 0
-      in
       let r =
         request c
           "(:op \"eval\" :code \"(defn step [] i64 (set ticks (+ ticks 9)) ticks)\" :file \"/tmp/never-landed.flan\")"
@@ -3110,13 +3033,7 @@ let () =
               else In_channel.with_open_bin dump In_channel.input_all
             in
             (try Sys.remove dump with Sys_error _ -> ());
-            let has hay needle =
+            let has = contains_sub in
-              let n = String.length needle and h = String.length hay in
-              let rec go i =
-                i + n <= h && (String.sub hay i n = needle || go (i + 1))
-              in
-              n > 0 && go 0
-            in
             if not (has text "dbg.flan") then
               fail
                 "a --debug daemon's module carries no line table for the form's \
@@ -4920,9 +4837,5 @@ let () =
 
     List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
       [ sock; out; bsock; bout ];
-    if !failures = 0 then print_endline "dev: all tests passed"
+    Test_support.report ~label:"dev" ()
-    else begin
-      Printf.printf "\n%d failure(s)\n" !failures;
-      exit 1
-    end
   | _ -> print_endline "dev: skipped (no clang or llc on PATH)"

test/test_dyn.ml

@@ -51,26 +51,15 @@ open Flan
    all. See watchdog.ml. *)
 let () = Watchdog.arm ~seconds:600 "test_dyn"
 
-let failures = ref 0
+let failures = Test_support.failures
-let fail fmt =
+let fail fmt = Test_support.fail fmt
-  Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL  " ^ s)) fmt
+let tmp name = Test_support.tmp "flan-dyn-" name
-
+let has = Test_support.contains
-let scratch = Filename.get_temp_dir_name ()
-let tmp name = Filename.concat scratch ("flan-dyn-" ^ name)
-
-let has hay needle =
-  let n = String.length needle and h = String.length hay in
-  let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in
-  go 0
 
 let () =
   match Sys.command "command -v clang > /dev/null 2>&1" with
   | 0 ->
-    let p =
+    let p = Test_support.checked "programs/dyn-host.flan" in
-      Check.program
-        (Load.program ~file:"programs/dyn-host.flan"
-           (Reader.read_file "programs/dyn-host.flan")).Load.decls
-    in
     let exe = tmp "ops" in
     ignore (Build.executable ~csrcs:[ "dyn_ops.c" ] p ~out:exe);
 

test/test_emacs.ml

@@ -12,53 +12,15 @@
 (* 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 ()
+(* The scratch paths, the poll and the daemon wait are in test_support.ml. The
-let tmp n = Filename.concat scratch ("flan-emacs-" ^ n)
+   long note on what [listening] can and cannot tell apart is there with it. *)
-
+let tmp n = Test_support.tmp "flan-emacs-" n
-let rec await ?(ms = 8000) f =
+let await = Test_support.await
-  if f () then true
+let listen_why = Test_support.listen_why
-  else if ms <= 0 then false
+let listening = Test_support.listening
-  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 () =
-  let have cmd = Sys.command (Printf.sprintf "command -v %s > /dev/null 2>&1" cmd) = 0 in
+  let have = Test_support.have in
   if not (have "emacs") then print_endline "emacs: skipped (no emacs on PATH)"
   else if not (have "clang" && have "llc") then
     print_endline "emacs: skipped (no clang or llc on PATH)"

test/test_flan.ml

@@ -7,7 +7,7 @@ open Flan
    nothing at all. See watchdog.ml. *)
 let () = Watchdog.arm ~seconds:600 "test_flan"
 
-let failures = ref 0
+let failures = Test_support.failures
 
 let check name cond =
   if not cond then begin
@@ -15,10 +15,7 @@ let check name cond =
     Printf.printf "FAIL  %s\n" name
   end
 
-let contains hay needle =
+let contains = Test_support.contains
-  let n = String.length needle and h = String.length hay in
-  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
@@ -281,11 +278,7 @@ let () =
      check "multi-line span has no single-line width" (Loc.width l.loc = None)
    | _ -> check "span: one multi-line form" false);
 
-  if !failures = 0 then print_endline "reader: all tests passed"
+  Test_support.report ~label:"reader" ()
-  else begin
-    Printf.printf "\n%d failure(s)\n" !failures;
-    exit 1
-  end
 
 (* ═══ Parse: forms → AST ═══════════════════════════════════════════ *)
 
@@ -677,11 +670,7 @@ let () =
        dep in test/dune and lands at the build root. *)
     [ "../calc-me.flan"; "../sand.flan" ];
 
-  if !failures = 0 then print_endline "parse: all tests passed"
+  Test_support.report ~label:"parse" ()
-  else begin
-    Printf.printf "\n%d failure(s)\n" !failures;
-    exit 1
-  end
 
 (* ═══ The return type is the slot, not a guess ══════════════ *)
 (* (Option f64) and (Some 1) are the same s-expression shape, and the parser
@@ -3579,8 +3568,4 @@ let () =
   accepts "calc-me.flan type checks"
     (In_channel.with_open_bin "../calc-me.flan" In_channel.input_all);
 
-  if !failures = 0 then print_endline "all tests passed"
+  Test_support.report ()
-  else begin
-    Printf.printf "\n%d failure(s)\n" !failures;
-    exit 1
-  end

test/test_reload.ml

@@ -25,15 +25,9 @@ open Flan
    nothing at all. See watchdog.ml. *)
 let () = Watchdog.arm ~seconds:600 "test_reload"
 
-let failures = ref 0
+let fail fmt = Test_support.fail fmt
-let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL  " ^ s)) fmt
+let tmp name = Test_support.tmp "flan-reload-" name
-
+let checked = Test_support.checked
-let scratch = Filename.get_temp_dir_name ()
-let tmp name = Filename.concat scratch ("flan-reload-" ^ name)
-
-let checked path =
-  Check.program
-    (Load.program ~file:path (Reader.read_file path)).Load.decls
 
 let ms f =
   let t0 = Unix.gettimeofday () in
@@ -632,9 +626,5 @@ let () =
 
     List.iter (fun p -> try Sys.remove p with Sys_error _ -> ())
       [ host; limits; so1; so2; so3; so4; so5; out; out5; err5; tmp "err" ];
-    if !failures = 0 then print_endline "reload: all tests passed"
+    Test_support.report ~label:"reload" ()
-    else begin
-      Printf.printf "\n%d failure(s)\n" !failures;
-      exit 1
-    end
   | _ -> print_endline "reload: skipped (no clang or llc on PATH)"

test/test_repl.ml

@@ -20,77 +20,24 @@ open Flan
    nothing at all. See watchdog.ml. *)
 let () = Watchdog.arm ~seconds:600 "test_repl"
 
-let failures = ref 0
+(* The counter, the poll, the daemon wait and the connect are all in
-let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL  " ^ s)) fmt
+   test_support.ml: see its header for why they are not here. *)
-
+let failures = Test_support.failures
-let scratch = Filename.get_temp_dir_name ()
+let fail fmt = Test_support.fail fmt
-let tmp n = Filename.concat scratch ("flan-repl-" ^ n)
+let tmp n = Test_support.tmp "flan-repl-" n
-
+let listen_why = Test_support.listen_why
-let rec await ?(ms = 8000) f =
+let listening = Test_support.listening
-  if f () then true
+let connect = Test_support.connect
-  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 =
+(* [Wire.quote] itself, not a copy of it: the escaping the daemon's own
-  let b = Buffer.create (String.length s + 8) in
+   replies are written with is the escaping a request has to be written with,
-  Buffer.add_char b '"';
+   and the case below named "every string escape survives the printer and the
-  String.iter
+   wire" is checking exactly that function's stated ground. *)
-    (fun c ->
+let quote = Wire.quote
-       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
@@ -112,7 +59,7 @@ let () =
     if not (listening ~pid sock) then
       fail "the daemon %s" !listen_why
     else begin
-      let c = connect sock in
+      let c = connect ~ms:8000 sock in
       let evals code =
         request c
           (Printf.sprintf "(:op \"eval-expr\" :code %s :file \"/tmp/buf.flan\")"

test/test_sanitize.ml

@@ -35,11 +35,9 @@ open Flan
    nothing at all. See watchdog.ml. *)
 let () = Watchdog.arm ~seconds:3600 "test_sanitize"
 
-let failures = ref 0
+let failures = Test_support.failures
-let fail fmt =
+let fail fmt = Test_support.fail fmt
-  Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL  " ^ s)) fmt
+let scratch = Test_support.scratch
-
-let scratch = Filename.get_temp_dir_name ()
 
 (* Leaks are off. Every allocation in the runtime is allocate-once-never-free
    by design — [rt_args] says so in its own comment — so LeakSanitizer here
@@ -70,18 +68,13 @@ let compile ~sanitize ~checks path =
          (if sanitize then "s" else "p")
          (Filename.remove_extension (Filename.basename path)))
   in
-  let l = Load.program ~file:path (Reader.read_file path) in
+  let p, csrcs, lflags = Test_support.linked path in
-  let p = Check.program l.Load.decls in
-  let p, csrcs, lflags = Reach.link ~dev:false l p in
   ignore
     (Build.executable
        ~opts:{ Build.default with checks; sanitize } ~csrcs ~lflags p ~out:exe);
   exe
 
-let contains hay needle =
+let contains = Test_support.contains
-  let n = String.length needle and h = String.length hay in
-  let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in
-  go 0
 
 (* What a report looks like, whichever sanitizer wrote it. *)
 let markers =
@@ -291,9 +284,7 @@ let sweep ~checks label =
 let dyn_sweep () =
   let exe = Filename.concat scratch "flan-san-dyn" in
   let path = "programs/dyn-host.flan" in
-  let l = Load.program ~file:path (Reader.read_file path) in
+  let p, csrcs, lflags = Test_support.linked path in
-  let p = Check.program l.Load.decls in
-  let p, csrcs, lflags = Reach.link ~dev:false l p in
   match
     Build.executable
       ~opts:{ Build.default with Build.sanitize = true }

test/test_session.ml

@@ -13,19 +13,12 @@ open Flan
    nothing at all. See watchdog.ml. *)
 let () = Watchdog.arm ~seconds:600 "test_session"
 
-let failures = ref 0
+let fail fmt = Test_support.fail fmt
-let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL  " ^ s)) fmt
+let has = Test_support.contains
-
-let has hay needle =
-  let n = String.length needle and h = String.length hay in
-  let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in
-  go 0
 
 (* Every rejection is asserted on its reason, not just on the failure: the
    reason is the part that has to survive a refactor. *)
-let checked_program file =
+let checked_program = Test_support.checked
-  Check.program
-    (Load.program ~file (Reader.read_file file)).Load.decls
 
 let refuses ?(file = "programs/reload.flan") name src reason =
   let t, _ = Session.create ~file () in
@@ -997,8 +990,4 @@ let () =
    | exception Loc.Error { Loc.dmsg = m; _ } ->
      fail "an expression that instantiates a generic: %s" m);
 
-  if !failures = 0 then print_endline "session: all tests passed"
+  Test_support.report ~label:"session" ()
-  else begin
-    Printf.printf "\n%d failure(s)\n" !failures;
-    exit 1
-  end

test/test_support.ml

@@ -0,0 +1,207 @@
+(* The plumbing every test binary in this directory needs, in one place.
+
+   Nothing here tests anything. It is the scaffolding the cases stand on: a
+   failure counter and the three lines that report it, a poll, a socket
+   connect that survives the bind/listen race, the wait for a [flan dev]
+   daemon to come up, a substring search, and the Load → Check → Reach.link
+   front half of a compile.
+
+   It exists because each of those had been written out again in every file
+   that wanted it — [listening] three times byte for byte apart from one
+   comment, the substring search ten times, a report tail in every suite — and
+   two of those copies carried a comment saying they were kept separate
+   because "these three files have no module between them". That was not true
+   when it was written: watchdog.ml was already named in the same
+   [(modules ...)] stanzas, which is exactly the module between them. This
+   file is the second such module, named in all four of test/dune's stanzas
+   the way watchdog is in three of them.
+
+   No [let () = ...] at the top level here on purpose. A module linked into
+   ten binaries must not do anything on the way in; the watchdog is armed by
+   each test's own first line, where the seconds are that test's decision. *)
+
+open Flan
+
+(* ── Failures, and the report of them ─────────────────────────────── *)
+
+(* One counter per process, and every [fail] goes through it. Each binary
+   binds its own [failures] to this ref rather than making one of its own, so
+   [report] below sees what the file's own [incr failures] did. *)
+let failures = ref 0
+
+let fail fmt =
+  Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL  " ^ s)) fmt
+
+(* The tail every suite ends on: a single line when nothing failed, and a
+   count plus a nonzero exit when something did. The label names the suite,
+   because these binaries run under dune's parallelism and their output is
+   interleaved — "all tests passed" on its own says nothing about which.
+   [?label] is optional for the one caller that has no label to give: the
+   last of test_flan.ml's three tails covers the whole file and has always
+   printed the bare sentence, and this keeps that byte for byte.
+
+   Not every tail in this directory is this one, and the others are left
+   where they are: test_repl.ml quotes the daemon's exit status underneath
+   the count, test_web.ml says "web: ok", and the two sweep binaries print a
+   count without exiting on the spot. Those differ because they report
+   different things, not because they drifted. *)
+let report ?label () =
+  if !failures = 0 then
+    print_endline
+      (match label with
+       | Some l -> l ^ ": all tests passed"
+       | None -> "all tests passed")
+  else begin
+    Printf.printf "\n%d failure(s)\n" !failures;
+    exit 1
+  end
+
+(* ── Strings ──────────────────────────────────────────────────────── *)
+
+(* Substring search, hand-written because Str is a dependency the rest of
+   this directory does not take (test_valgrind.ml is the one exception, and
+   it takes it for a regexp over memcheck's summary line).
+
+   An empty needle is contained in anything, which is the answer the majority
+   of the copies this replaces gave and the one that agrees with every other
+   [contains] in the world. Three inline copies in test_dev.ml answered
+   [false] instead; every needle passed to any of them was a non-empty string
+   literal, so no call site could tell the difference. *)
+let contains hay needle =
+  let n = String.length needle and h = String.length hay in
+  let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in
+  go 0
+
+(* ── Scratch files ────────────────────────────────────────────────── *)
+
+let scratch = Filename.get_temp_dir_name ()
+
+(* [tmp prefix name] is a path in the scratch directory. The prefix is the
+   caller's, not a default, and that is the point: these binaries run at the
+   same time under dune, so "flan-agent-dev.sock" and "flan-repl-dev.sock"
+   being different files is what keeps two suites from unlinking each other's
+   sockets. *)
+let tmp prefix name = Filename.concat scratch (prefix ^ name)
+
+(* ── Toolchain probes ─────────────────────────────────────────────── *)
+
+(* Whether a program is on PATH. Missing tools are a skip with the reason in
+   this directory, never a red test — the compiler does not depend on emacs,
+   emscripten or valgrind being installed. *)
+let have prog =
+  Sys.command (Printf.sprintf "command -v %s > /dev/null 2>&1" prog) = 0
+
+(* ── Waiting ──────────────────────────────────────────────────────── *)
+
+(* Poll for a condition rather than sleeping a fixed time: a program has to
+   bind its socket before there is anything to connect to, and how long that
+   takes is not ours to predict. Five milliseconds a turn, [ms] milliseconds
+   in total, [false] if the budget ran out.
+
+   Five seconds by default, which is what test_dev.ml's copy had and what its
+   several dozen bare call sites were written against. The callers that want
+   another budget pass one. *)
+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
+
+(* The socket file appears at [bind], which is a moment before [listen], so a
+   connect can lose that race and get ECONNREFUSED. Retry rather than sleep.
+
+   ECONNREFUSED and not any [Unix_error], which is the narrower of the two
+   spellings this had grown. The wide one retried ENOENT and EACCES to the
+   full timeout as well, so a path that was never going to exist cost seconds
+   before raising something a reader still had to interpret; narrowed, those
+   two come straight back out of [Unix.connect] with their own name on them.
+   Every caller here connects to a socket [listening] has already seen on
+   disk, so the race this does catch is the only one left. *)
+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 (Unix.ECONNREFUSED, _, _) when ms > 0 ->
+    Unix.close s;
+    ignore (Unix.select [] [] [] 0.005);
+    connect ~ms:(ms - 5) path
+
+(* Waiting for a daemon to listen is waiting for two different things with one
+   timer: [flan dev] compiles the whole program first, and only then binds. The
+   old message, "the daemon never listened", named the second and was almost
+   always the first — which is a wrong diagnosis, and a wrong diagnosis costs
+   more than no message at all.
+
+   So this says which. It cannot separate the two waits without a signal from
+   [flan dev] that the build is done (see NEXT.md), but it can separate the two
+   *failures*, and that is what actually gets read: a daemon still running when
+   the timer expires was building, and a daemon that is gone bound nothing
+   because it died. The second no longer costs the whole timeout either —
+   the poll watches the process as well as the socket, so a crash fails in
+   milliseconds instead of in half a minute, which is the part that makes a
+   suite worth trusting.
+
+   Thirty seconds, down from a minute, because the object cache is durable now
+   (Build.cachedir) and the build this waits on is warm: 0.48s idle against
+   2.0s cold, and the worst ever measured under dune's own parallelism was
+   6.8s — cold. Each caller's watchdog is still what bounds its run.
+
+   [!listen_why] carries the reason to the caller so each site can keep its own
+   name for its daemon. One ref is enough even though three binaries now share
+   this code: they are three processes, each single-threaded, and the next
+   thing after a failed wait is always the report of it. *)
+let listen_why = ref ""
+
+let listening ?(ms = 30000) ~pid path =
+  let died = ref None in
+  ignore
+    (await ~ms (fun () ->
+         Sys.file_exists path
+         ||
+         (* Reaped only once it is already gone, and only on the path that ends
+            in a failure, so a teardown's own [waitpid] is unaffected. *)
+         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
+
+(* ── The front half of a compile ──────────────────────────────────── *)
+
+(* Read, load and check a program: the same two calls [flan build] makes
+   before it reaches the backend. Through [Load], so a program with an
+   (import ...) is buildable here — it brings back the package's declarations
+   as well as the file's own. *)
+let checked path =
+  Check.program (Load.program ~file:path (Reader.read_file path)).Load.decls
+
+(* And the third call, which is where the binaries below actually differ from
+   one another: [Reach.link] decides the link from the checked program — a
+   package nothing reachable calls into hands over no C and no linker
+   argument, and its functions are not emitted — and returns the program
+   together with the C sources and linker flags the build needs.
+
+   This stops at [Build.executable] deliberately. Every caller passes a
+   different [Build.opts] (a sanitized build, a -O0 one, an x86 one, a web
+   one) and several want the exception rather than the executable, so the
+   options record is the one part that is genuinely theirs. *)
+let linked ?(dev = false) path =
+  let l = Load.program ~file:path (Reader.read_file path) in
+  let p = Check.program l.Load.decls in
+  Reach.link ~dev l p

test/test_valgrind.ml

@@ -36,11 +36,9 @@ open Flan
    slower, so the clock is looser than the sanitize sweep's. See watchdog.ml. *)
 let () = Watchdog.arm ~seconds:5400 "test_valgrind"
 
-let failures = ref 0
+let failures = Test_support.failures
-let fail fmt =
+let fail fmt = Test_support.fail fmt
-  Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL  " ^ s)) fmt
+let scratch = Test_support.scratch
-
-let scratch = Filename.get_temp_dir_name ()
 let supp = "valgrind.supp"
 
 (* Leak checking is off, and the reason is [test_sanitize.ml]'s reason for
@@ -98,9 +96,7 @@ let compile ~checks path =
          (if checks then "c" else "u")
          (Filename.remove_extension (Filename.basename path)))
   in
-  let l = Load.program ~file:path (Reader.read_file path) in
+  let p, csrcs, lflags = Test_support.linked path in
-  let p = Check.program l.Load.decls in
-  let p, csrcs, lflags = Reach.link ~dev:false l p in
   ignore
     (Build.executable
        ~opts:{ Build.default with checks } ~csrcs ~lflags p ~out:exe);

test/test_web.ml

@@ -14,11 +14,9 @@
 
 open Flan
 
-let failures = ref 0
+let failures = Test_support.failures
-
+let scratch = Test_support.scratch
-let scratch = Filename.get_temp_dir_name ()
+let fail fmt = Test_support.fail fmt
-
-let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL  " ^ s)) fmt
 
 let read path =
   let ch = open_in_bin path in
@@ -26,19 +24,13 @@ let read path =
   let s = really_input_string ch n in
   close_in ch; s
 
-let contains hay needle =
+let contains = Test_support.contains
-  let n = String.length needle and h = String.length hay in
+let have = Test_support.have
-  let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in
-  go 0
-
-let have prog = Sys.command (Printf.sprintf "command -v %s > /dev/null 2>&1" prog) = 0
 
 (* One web build, through [Load] and [Reach] exactly as [flan build] does it,
    so a package's per-target link lines are selected here too. *)
 let web_build ?(opt = "-O2") path out =
-  let l = Load.program ~file:path (Reader.read_file path) in
+  let p, csrcs, lflags = Test_support.linked path in
-  let p = Check.program l.Load.decls in
-  let p, csrcs, lflags = Reach.link l p in
   ignore
     (Build.executable ~opts:{ Build.default with opt; target = Some "web" }
        ~csrcs ~lflags p ~out)
@@ -279,11 +271,7 @@ let () =
       else if not (contains m why) then
         fail "%s was refused for the wrong reason: wanted %S, said %S" what why m
   in
-  let unit_main () =
+  let unit_main () = Test_support.checked "programs/unit-main.flan" in
-    let path = "programs/unit-main.flan" in
-    let l = Load.program ~file:path (Reader.read_file path) in
-    Check.program l.Load.decls
-  in
   refused "--dev --target=web" "--dev is native only" (fun () ->
     ignore
       (Build.executable ~opts:{ Build.default with target = Some "web"; dev = true }