Source file pp.ml

(*
 * Copyright (c) 2013-2016 Thomas Gazagnaire <thomas@gazagnaire.org>
 * Copyright (c) 2019      Craig Ferguson    <craig@tarides.com>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *)

open Model
open Utils

let terminal_width () = 80

type event = [ `Result of Test_name.t * Run_result.t | `Start of Test_name.t ]

let rresult_error ppf = function
  | `Error (_, e) -> Fmt.pf ppf "%a@," e ()
  | `Exn (_, n, e) -> Fmt.pf ppf "[%s] @[<v>%a@]" n e ()
  | `Ok | `Todo _ | `Skip -> ()

(* Colours *)
let color c ppf fmt = Fmt.(styled c string) ppf fmt

let red_s fmt = color `Red fmt

let red ppf fmt = Fmt.kstrf (fun str -> red_s ppf str) fmt

let green_s fmt = color `Green fmt

let yellow_s fmt = color `Yellow fmt

let left_c = 14

let left nb pp ppf a =
  let s = Fmt.to_to_string pp a in
  let nb = nb - String.length_utf8 s in
  if nb <= 0 then pp ppf a
  else (
    pp ppf a;
    Fmt.string ppf (String.v ~len:nb (fun _ -> ' ')) )

let pp_test_name ~max_label ppf tname =
  let name_len = Test_name.length tname in
  let index = Test_name.index tname in
  let padding =
    match max_label + 8 - name_len with
    | n when n <= 0 -> ""
    | n -> String.v ~len:n (fun _ -> ' ')
  in
  Fmt.pf ppf "%a%s%3d" Fmt.(styled `Cyan Test_name.pp) tname padding index

let info ~max_label ~doc_of_test_name ppf tname =
  Fmt.pf ppf "%a   %s" (pp_test_name ~max_label) tname (doc_of_test_name tname)

let tag_of_result = function
  | `Ok -> `Ok
  | `Exn _ | `Error _ -> `Fail
  | `Skip -> `Skip
  | `Todo _ -> `Todo

let colour_of_tag = function
  | `Ok -> `Green
  | `Fail -> `Red
  | `Skip | `Todo | `Assert -> `Yellow

let string_of_tag = function
  | `Ok -> "OK"
  | `Fail -> "FAIL"
  | `Skip -> "SKIP"
  | `Todo -> "TODO"
  | `Assert -> "ASSERT"

let pp_tag ~wrapped ppf typ =
  let colour = colour_of_tag typ in
  let tag = string_of_tag typ in
  let tag = if wrapped then "[" ^ tag ^ "]" else tag in
  Fmt.(styled colour string) ppf tag

let tag = pp_tag ~wrapped:false

let pp_result ppf result =
  let tag = tag_of_result result in
  left left_c (pp_tag ~wrapped:true) ppf tag

let pp_result_compact ppf result =
  let colour = result |> tag_of_result |> colour_of_tag in
  let char =
    match result with
    | `Ok -> '.'
    | `Exn _ | `Error _ -> 'F'
    | `Skip -> 'S'
    | `Todo _ -> 'T'
  in
  Fmt.(styled colour char) ppf char

let left_padding ~with_selector =
  let open Fmt in
  ( if with_selector then const (styled `Bold (styled `Red char)) '>'
  else const char ' ' )
  ++ const char ' '

let pp_result_full ~max_label ~doc_of_test_name ~selector_on_failure ppf
    (path, result) =
  let with_selector = selector_on_failure && Run_result.is_failure result in
  (left_padding ~with_selector) ppf ();
  pp_result ppf result;
  (info ~max_label ~doc_of_test_name) ppf path;
  ()

let event_line ~max_label ~doc_of_test_name ppf = function
  | `Result (p, r) ->
      pp_result ppf r;
      (info ~max_label ~doc_of_test_name) ppf p
  | _ -> assert false

let event ~isatty ~compact ~max_label ~doc_of_test_name ~selector_on_failure
    ~tests_so_far ppf event =
  match (compact, isatty, event) with
  | true, _, `Start _ | _, false, `Start _ -> ()
  | false, true, `Start tname ->
      Fmt.(
        left_padding ~with_selector:false
        ++ const (left left_c yellow_s) "..."
        ++ const (info ~max_label ~doc_of_test_name) tname)
        ppf ()
  | true, _, `Result (_, r) ->
      pp_result_compact ppf r;
      (* Wrap compact output to terminal width manually *)
      if (tests_so_far + 1) mod terminal_width () = 0 then
        Format.pp_force_newline ppf ();
      ()
  | false, _, `Result (tname, r) ->
      if isatty then Fmt.pf ppf "\r";
      Fmt.pf ppf "%a@,"
        (pp_result_full ~max_label ~doc_of_test_name ~selector_on_failure)
        (tname, r)

type result = {
  success : int;
  failures : int;
  time : float;
  errors : unit Fmt.t list;
}

let pp_suite_errors ~show_all = function
  | [] -> Fmt.nop
  | x :: _ as xs -> (if show_all then xs else [ x ]) |> Fmt.concat

let pp_plural ppf x = Fmt.pf ppf (if x < 2 then "" else "s")

let quoted f = Fmt.(const char '`' ++ f ++ const char '\'')

let with_surrounding_box (type a) (f : a Fmt.t) : a Fmt.t =
 fun ppf a ->
  (* Peek at the value being pretty-printed to determine the length of the box
     we're going to need. Fortunately, this will not include ANSII colour
     escapes. *)
  let true_width = Fmt.kstr String.length_utf8 "| %a |" f a in
  let min_width = terminal_width () in
  let width = max min_width true_width in

  let right_padding = String.v ~len:(width - true_width) (fun _ -> ' ') in
  let s = Fmt.(const (styled `Faint string)) in
  let bars = List.init (width - 2) (fun _ -> "─") |> String.concat in
  let top = s ("┌" ^ bars ^ "┐")
  and mid = Fmt.(s "│ " ++ f ++ s (right_padding ^ " │"))
  and bottom = s ("└" ^ bars ^ "┘") in
  Fmt.(top ++ cut ++ mid ++ cut ++ bottom ++ cut) ppf a

let horizontal_rule (type a) ppf (_ : a) =
  let open Fmt in
  ( const string " "
  ++ const
       (styled `Faint string)
       (List.init (terminal_width () - 2) (fun _ -> "─") |> String.concat)
  ++ cut )
    ppf ()

let pp_full_logs ppf log_dir =
  Fmt.pf ppf "Full test results in %a.@,"
    Fmt.(quoted (styled `Cyan string))
    log_dir

let pp_summary ppf r =
  let pp_failures ppf = function
    | 0 -> green_s ppf "Test Successful"
    | n -> red ppf "%d failure%a!" n pp_plural n
  in
  Fmt.pf ppf "%a in %.3fs. %d test%a run.@," pp_failures r.failures r.time
    r.success pp_plural r.success

let suite_results ~verbose ~show_errors ~json ~compact ~log_dir ppf r =
  let print_summary = (not compact) || r.failures > 0 in
  match json with
  | true ->
      (* Return the json for the api, dirty out, to avoid new dependencies *)
      Fmt.pf ppf {|{
  "success": %i,
  "failures": %i,
  "time": %f
}
|}
        r.success r.failures r.time
  | false ->
      Format.pp_force_newline ppf ();
      Format.pp_open_vbox ppf 0;
      if compact then Fmt.cut ppf ();
      (pp_suite_errors ~show_all:(verbose || show_errors) r.errors) ppf ();
      if print_summary then (
        if not verbose then pp_full_logs ppf log_dir;
        pp_summary ppf r );
      Format.pp_close_box ppf ()

let user_error msg =
  Fmt.epr "%a: %s\n" Fmt.(styled `Red string) "ERROR" msg;
  exit 1