Add optional location information on test assertion functions

CHANGES.md

@@ -8,6 +8,10 @@
   several display issues due to line wrapping in small terminals. (#282,
   @CraigFe)
 
+- Add `?here` and `?pos` arguments to the test assertion functions. These can be
+  used to pass information about the location of the call-site, which is
+  displayed in failing test output. (#291, @CraigFe)
+
 ### 1.2.3 (2020-09-07)
 
 - Require Dune 2.2. (#274, @CraigFe)

src/alcotest-engine/test.ml

@@ -157,7 +157,28 @@ let show_assert msg =
 
 let check_err fmt = raise (Core.Check_error fmt)
 
-let check (type a) (t : a testable) msg (expected : a) (actual : a) =
+module Source_code_position = struct
+  type here = Lexing.position
+
+  type pos = string * int * int * int
+end
+
+type 'a extra_info =
+  ?here:Source_code_position.here -> ?pos:Source_code_position.pos -> 'a
+
+let pp_location =
+  let pp =
+    Fmt.styled `Bold (fun ppf (f, l, c) ->
+        Fmt.pf ppf "File \"%s\", line %d, character %d:@," f l c)
+  in
+  fun ?here ?pos ppf ->
+    match (here, pos) with
+    | Some (here : Source_code_position.here), _ ->
+        pp ppf (here.pos_fname, here.pos_lnum, here.pos_cnum - here.pos_bol)
+    | _, Some (fname, lnum, cnum, _) -> pp ppf (fname, lnum, cnum)
+    | None, None -> ()
+
+let check (type a) ?here ?pos (t : a testable) msg (expected : a) (actual : a) =
   show_assert msg;
   if not (equal t expected actual) then
     let open Fmt in
@@ -173,15 +194,25 @@ let check (type a) (t : a testable) msg (expected : a) (actual : a) =
     in
     raise
       (Core.Check_error
-         Fmt.(vbox (pp_error ++ cut ++ cut ++ pp_expected ++ cut ++ pp_actual)))
-
-let check' t ~msg ~expected ~actual = check t msg expected actual
-
-let fail msg =
+         Fmt.(
+           vbox
+             ((fun ppf () -> pp_location ?here ?pos ppf)
+             ++ pp_error
+             ++ cut
+             ++ cut
+             ++ pp_expected
+             ++ cut
+             ++ pp_actual)))
+
+let check' ?here ?pos t ~msg ~expected ~actual =
+  check ?here ?pos t msg expected actual
+
+let fail ?here ?pos msg =
   show_assert msg;
-  check_err (fun ppf () -> Fmt.pf ppf "%a %s" Pp.tag `Fail msg)
+  check_err (fun ppf () ->
+      Fmt.pf ppf "%t%a %s" (pp_location ?here ?pos) Pp.tag `Fail msg)
 
-let failf fmt = Fmt.kstrf fail fmt
+let failf ?here ?pos fmt = Fmt.kstrf (fun msg -> fail ?here ?pos msg) fmt
 
 let neg t = testable (pp t) (fun x y -> not (equal t x y))
 
@@ -191,17 +222,17 @@ let collect_exception f =
     None
   with e -> Some e
 
-let check_raises msg exn f =
+let check_raises ?here ?pos msg exn f =
   show_assert msg;
   match collect_exception f with
   | None ->
       check_err (fun ppf () ->
-          Fmt.pf ppf "%a %s: expecting %s, got nothing." Pp.tag `Fail msg
-            (Printexc.to_string exn))
+          Fmt.pf ppf "%t%a %s: expecting %s, got nothing."
+            (pp_location ?here ?pos) Pp.tag `Fail msg (Printexc.to_string exn))
   | Some e ->
       if e <> exn then
         check_err (fun ppf () ->
-            Fmt.pf ppf "%a %s: expecting %s, got %s." Pp.tag `Fail msg
-              (Printexc.to_string exn) (Printexc.to_string e))
+            Fmt.pf ppf "%t%a %s: expecting %s, got %s." (pp_location ?here ?pos)
+              Pp.tag `Fail msg (Printexc.to_string exn) (Printexc.to_string e))
 
 let () = at_exit (Format.pp_print_flush Format.err_formatter)

src/alcotest-engine/test.mli

@@ -14,6 +14,11 @@
  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  *)
 
+(** {1 Testable values}
+
+    The following combinators represent types that can be used with the {!check}
+    functions below. *)
+
 (** [TESTABLE] provides an abstract description for testable values. *)
 module type TESTABLE = sig
   type t
@@ -98,21 +103,44 @@ val pass : 'a testable
 val reject : 'a testable
 (** [reject] tests values of any type and always fails. *)
 
-val check : 'a testable -> string -> 'a -> 'a -> unit
+val neg : 'a testable -> 'a testable
+(** [neg t] is [t]'s negation: it is [true] when [t] is [false] and it is
+    [false] when [t] is [true]. *)
+
+(** {1 Assertion functions}
+
+    Functions for asserting various properties within unit-tests. A failing
+    assertion will cause the testcase to fail immediately. *)
+
+module Source_code_position : sig
+  type here = Lexing.position
+  (** Location information passed via a [~here] argument, intended for use with
+      a PPX such as {{:https://github.com/janestreet/ppx_here} [ppx_here]}. *)
+
+  type pos = string * int * int * int
+  (** Location information passed via a [~pos] argument, intended for use with
+      the [__POS__] macro provided by the standard library. See the
+      documentation of [__POS__] for more information. *)
+end
+
+type 'a extra_info =
+  ?here:Source_code_position.here -> ?pos:Source_code_position.pos -> 'a
+(** The assertion functions optionally take information about the {i location}
+    at which they are called in the source code. This is used for giving more
+    descriptive error messages in the case of failure. *)
+
+val check : ('a testable -> string -> 'a -> 'a -> unit) extra_info
 (** Check that two values are equal. *)
 
-val check' : 'a testable -> msg:string -> expected:'a -> actual:'a -> unit
+val check' :
+  ('a testable -> msg:string -> expected:'a -> actual:'a -> unit) extra_info
 (** Check that two values are equal (labeled variant of {!check}). *)
 
-val fail : string -> 'a
+val fail : (string -> 'a) extra_info
 (** Simply fail. *)
 
-val failf : ('a, Format.formatter, unit, 'b) format4 -> 'a
+val failf : (('a, Format.formatter, unit, 'b) format4 -> 'a) extra_info
 (** Simply fail with a formatted message. *)
 
-val neg : 'a testable -> 'a testable
-(** [neg t] is [t]'s negation: it is [true] when [t] is [false] and it is
-    [false] when [t] is [true]. *)
-
-val check_raises : string -> exn -> (unit -> unit) -> unit
+val check_raises : (string -> exn -> (unit -> unit) -> unit) extra_info
 (** Check that an exception is raised. *)

src/alcotest/alcotest.mli

@@ -29,8 +29,6 @@
 
 include Alcotest_engine.Cli.S with type return = unit
 
-(** {1 Assert functions} *)
-
 include module type of Alcotest_engine.Test
 (** @inline *)
 

test/e2e/alcotest/failing/check_located.expected

@@ -0,0 +1,70 @@
+Testing `test/e2e/alcotest/failing/check_located.ml'.
+This run has ID `<uuid>'.
+
+ASSERT Expected failure
+  [FAIL]        check                 0   here.
+ASSERT Expected failure
+  [FAIL]        check                 1   pos.
+ASSERT Expected failure
+  [FAIL]        check_raises          0   here.
+ASSERT Expected failure
+  [FAIL]        check_raises          1   pos.
+ASSERT Expected failure
+  [FAIL]        fail                  0   here.
+ASSERT Expected failure
+  [FAIL]        fail                  1   pos.
+
+┌──────────────────────────────────────────────────────────────────────────────┐
+│ [FAIL]        check                 0   here.                                │
+└──────────────────────────────────────────────────────────────────────────────┘
+File "test/e2e/alcotest/failing/check_located.ml", line 2, character 30:
+FAIL Expected failure
+
+   Expected: `true'
+   Received: `false'
+ ──────────────────────────────────────────────────────────────────────────────
+
+
+┌──────────────────────────────────────────────────────────────────────────────┐
+│ [FAIL]        check                 1   pos.                                 │
+└──────────────────────────────────────────────────────────────────────────────┘
+File "test/e2e/alcotest/failing/check_located.ml", line 4, character 10:
+FAIL Expected failure
+
+   Expected: `true'
+   Received: `false'
+ ──────────────────────────────────────────────────────────────────────────────
+
+
+┌──────────────────────────────────────────────────────────────────────────────┐
+│ [FAIL]        check_raises          0   here.                                │
+└──────────────────────────────────────────────────────────────────────────────┘
+File "test/e2e/alcotest/failing/check_located.ml", line 2, character 30:
+FAIL Expected failure: expecting Failure(""), got nothing.
+ ──────────────────────────────────────────────────────────────────────────────
+
+
+┌──────────────────────────────────────────────────────────────────────────────┐
+│ [FAIL]        check_raises          1   pos.                                 │
+└──────────────────────────────────────────────────────────────────────────────┘
+File "test/e2e/alcotest/failing/check_located.ml", line 4, character 10:
+FAIL Expected failure: expecting Failure(""), got nothing.
+ ──────────────────────────────────────────────────────────────────────────────
+
+
+┌──────────────────────────────────────────────────────────────────────────────┐
+│ [FAIL]        fail                  0   here.                                │
+└──────────────────────────────────────────────────────────────────────────────┘
+File "test/e2e/alcotest/failing/check_located.ml", line 2, character 30:
+FAIL Expected failure
+ ──────────────────────────────────────────────────────────────────────────────
+
+
+┌──────────────────────────────────────────────────────────────────────────────┐
+│ [FAIL]        fail                  1   pos.                                 │
+└──────────────────────────────────────────────────────────────────────────────┘
+File "test/e2e/alcotest/failing/check_located.ml", line 4, character 10:
+FAIL Expected failure
+ ──────────────────────────────────────────────────────────────────────────────
+
+6 failures! in <test-duration>s. 6 tests run.

test/e2e/alcotest/failing/check_located.ml

@@ -0,0 +1,28 @@
+let here : Lexing.position =
+  { pos_fname = __FILE__; pos_lnum = 2; pos_bol = 20; pos_cnum = 50 }
+
+let pos = __POS__
+
+let () =
+  let open Alcotest in
+  let msg = "Expected failure" in
+  let tc msg f = Alcotest.test_case msg `Quick f in
+  run ~verbose:true __FILE__
+    [
+      ( "check",
+        [
+          tc "here" (fun () -> check ~here bool msg true false);
+          tc "pos" (fun () -> check ~pos bool msg true false);
+        ] );
+      ( "check_raises",
+        [
+          tc "here" (fun () ->
+              check_raises ~here msg (Failure "") (fun () -> ()));
+          tc "pos" (fun () -> check_raises ~pos msg (Failure "") (fun () -> ()));
+        ] );
+      ( "fail",
+        [
+          tc "here" (fun () -> fail ~here msg);
+          tc "pos" (fun () -> fail ~pos msg);
+        ] );
+    ]

test/e2e/alcotest/failing/dune.inc

@@ -1,6 +1,7 @@
 (executables
  (names
    check_basic
+   check_located
    check_long
    compact
    duplicate_test_names
@@ -16,6 +17,7 @@
  (libraries alcotest alcotest.engine)
  (modules
    check_basic
+   check_located
    check_long
    compact
    duplicate_test_names
@@ -49,6 +51,25 @@
  (action
    (diff check_basic.expected check_basic.processed)))
 
+(rule
+ (target check_located.actual)
+ (action
+  (with-outputs-to %{target}
+   (with-accepted-exit-codes (or 1 125)
+    (run %{dep:check_located.exe})))))
+
+(rule
+ (target check_located.processed)
+ (action
+  (with-outputs-to %{target}
+   (run ../../strip_randomness.exe %{dep:check_located.actual}))))
+
+(rule
+ (alias runtest)
+ (package alcotest)
+ (action
+   (diff check_located.expected check_located.processed)))
+
 (rule
  (target check_long.actual)
  (action