diff --git a/src/testlib/containers_testlib.ml b/src/testlib/containers_testlib.ml index 12914132..be673507 100644 --- a/src/testlib/containers_testlib.ml +++ b/src/testlib/containers_testlib.ml @@ -7,7 +7,7 @@ type 'a print = 'a -> string module Test = struct type run = - | T of (unit -> bool) + | T of { prop: unit -> bool } | Eq : { eq: 'a eq option; print: 'a print option; lhs: 'a; rhs: 'a } -> run | Q : { count: int option; @@ -17,11 +17,16 @@ module Test = struct } -> run - type t = { run: run; __FILE__: string; n: int } + type t = { name: string option; run: run; __FILE__: string; n: int } (** Location for this test *) let str_loc (self : t) : string = - Printf.sprintf "(test :file '%s' :n %d)" self.__FILE__ self.n + let what = + match self.name with + | None -> "" + | Some f -> spf " :name %S" f + in + Printf.sprintf "(test :file '%s'%s :n %d)" self.__FILE__ what self.n [@@@ifge 4.08] @@ -38,12 +43,15 @@ module Test = struct let run ~seed (self : t) : _ result = match + let what = CCOption.map_or ~default:"" (fun s -> s ^ " ") self.name in match self.run with - | T f -> - if f () then - Ok () - else - Error "failed: returns false" + | T { prop } -> + let fail msg = Error (spf "%sfailed: %s" what msg) in + + (match prop () with + | exception e -> fail (spf "raised %s" (Printexc.to_string e)) + | true -> Ok () + | false -> fail "returns false") | Eq { eq; print; lhs; rhs } -> let eq = match eq with @@ -55,8 +63,9 @@ module Test = struct else ( let msg = match print with - | None -> "failed: not equal" - | Some p -> spf "failed: not equal:\nlhs=%s\nrhs=%s" (p lhs) (p rhs) + | None -> spf "%sfailed: not equal" what + | Some p -> + spf "%s failed: not equal:\nlhs=%s\nrhs=%s" what (p lhs) (p rhs) in Error msg ) @@ -97,18 +106,18 @@ module Test = struct | QCheck.TestResult.Success -> Ok () | QCheck.TestResult.Failed { instances } -> let msg = - Format.asprintf "@[failed on instances:@ %a@]" + Format.asprintf "@[%sfailed on instances:@ %a@]" what (Fmt.list ~sep:(Fmt.return ";@ ") pp_cex) instances in Error msg | QCheck.TestResult.Failed_other { msg } -> - let msg = spf "failed: %s" msg in + let msg = spf "%sfailed: %s" what msg in Error msg | QCheck.TestResult.Error { instance; exn; backtrace } -> let msg = - Format.asprintf "@[raised %s@ on instance %a@ :backtrace %s@]" - (Printexc.to_string exn) pp_cex instance backtrace + Format.asprintf "@[%sraised %s@ on instance %a@ :backtrace %s@]" + what (Printexc.to_string exn) pp_cex instance backtrace in Error msg) with @@ -119,11 +128,16 @@ end module type S = sig module Q = QCheck - val t : (unit -> bool) -> unit - val eq : ?cmp:'a eq -> ?printer:'a print -> 'a -> 'a -> unit + val t : ?name:string -> (unit -> bool) -> unit + val eq : ?name:string -> ?cmp:'a eq -> ?printer:'a print -> 'a -> 'a -> unit val q : - ?count:int -> ?long_factor:int -> 'a Q.arbitrary -> ('a -> bool) -> unit + ?name:string -> + ?count:int -> + ?long_factor:int -> + 'a Q.arbitrary -> + ('a -> bool) -> + unit val assert_equal : ?printer:('a -> string) -> ?cmp:('a -> 'a -> bool) -> 'a -> 'a -> unit @@ -144,18 +158,18 @@ struct let add_ t = all_ := t :: !all_ let n_ = ref 0 - let mk run : Test.t = + let mk ?name run : Test.t = let n = !n_ in incr n_; - { __FILE__ = X.file; n; run } + { __FILE__ = X.file; name; n; run } - let t f : unit = add_ @@ mk @@ Test.T f + let t ?name f : unit = add_ @@ mk ?name @@ Test.T { prop = f } - let eq ?cmp ?printer lhs rhs : unit = - add_ @@ mk @@ Test.Eq { eq = cmp; print = printer; lhs; rhs } + let eq ?name ?cmp ?printer lhs rhs : unit = + add_ @@ mk ?name @@ Test.Eq { eq = cmp; print = printer; lhs; rhs } - let q ?count ?long_factor arb prop : unit = - add_ @@ mk @@ Test.Q { arb; prop; count; long_factor } + let q ?name ?count ?long_factor arb prop : unit = + add_ @@ mk ?name @@ Test.Q { arb; prop; count; long_factor } let assert_equal ?printer ?(cmp = ( = )) x y : unit = if not @@ cmp x y then ( diff --git a/src/testlib/containers_testlib.mli b/src/testlib/containers_testlib.mli index 0e6aeff9..f910714e 100644 --- a/src/testlib/containers_testlib.mli +++ b/src/testlib/containers_testlib.mli @@ -8,11 +8,16 @@ end module type S = sig module Q = QCheck - val t : (unit -> bool) -> unit - val eq : ?cmp:'a eq -> ?printer:'a print -> 'a -> 'a -> unit + val t : ?name:string -> (unit -> bool) -> unit + val eq : ?name:string -> ?cmp:'a eq -> ?printer:'a print -> 'a -> 'a -> unit val q : - ?count:int -> ?long_factor:int -> 'a Q.arbitrary -> ('a -> bool) -> unit + ?name:string -> + ?count:int -> + ?long_factor:int -> + 'a Q.arbitrary -> + ('a -> bool) -> + unit val assert_equal : ?printer:('a -> string) -> ?cmp:('a -> 'a -> bool) -> 'a -> 'a -> unit