mbarbin / error-log / 25

Committed 12 May 2024 05:01PM UTC coverage: 99.683%. First build

Build # 25

Build Type

push

github

Committed by

mbarbin

Commit Message

Add [Error_log.am_running_test]

Run Details

0 of 1 new or added line in 1 file covered. (0.0%)

314 of 315 relevant lines covered (99.68%)

4.63 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

98.96

/src/error_log.ml

open! Or_error.Let_syntax
module Style = Stdune.User_message.Style

(* We do [@@@coverage off] of ppx deriving constructs due to a generated
   non visitable coverage point:

   {[
     let _ =
       fun (_ : t) ->
       ___bisect_visit___ 0;
       ()
     ;;
   ]}

   This is a known issue with work in progress to fix.

   https://github.com/mbarbin/error-log/issues/1
*)

module Config = struct
  module Mode = struct
    module T0 = struct
      [@@@coverage off]

      type t =
        | Quiet
        | Default
        | Verbose
        | Debug
      [@@deriving compare, equal, enumerate, sexp_of]
    end

    include T0

    let switch t = "--" ^ (Sexp.to_string (sexp_of_t t) |> String.uncapitalize)
  end

  module Warn_error = struct
    module T0 = struct
      [@@@coverage off]

      type t = bool [@@deriving equal, sexp_of]
    end

    include T0

    let switch = "--warn-error"
  end

  type t =
    { mode : Mode.t
    ; warn_error : Warn_error.t
    }
  [@@deriving equal, sexp_of]

  let default = { mode = Default; warn_error = false }

  let create ?(mode = default.mode) ?(warn_error = default.warn_error) () =
    { mode; warn_error }
  ;;

  let param =
    let open Command.Let_syntax in
    let%map_open mode =
      let verbose =
        if%map
          flag
            (Mode.switch Verbose)
            ~aliases:[ "v"; "verbose" ]
            no_arg
            ~doc:" print more messages"
        then Some Mode.Verbose
        else None
      and debug =
        if%map
          flag
            (Mode.switch Debug)
            ~aliases:[ "d"; "debug" ]
            no_arg
            ~doc:" enable all messages including debug output"
        then Some Mode.Debug
        else None
      and quiet =
        if%map
          flag
            (Mode.switch Quiet)
            ~aliases:[ "q"; "-quiet" ]
            no_arg
            ~doc:" suppress output except errors"
        then Some Mode.Quiet
        else None
      in
      choose_one [ debug; verbose; quiet ] ~if_nothing_chosen:(Default_to Mode.Default)
    and warn_error =
      if%map flag Warn_error.switch no_arg ~doc:" treat warnings as errors"
      then true
      else false
    in
    { mode; warn_error }
  ;;

  let to_params { mode; warn_error } =
    List.concat
      [ (match mode with
         | Default -> []
         | (Quiet | Verbose | Debug) as mode -> [ Mode.switch mode ])
      ; (if warn_error then [ Warn_error.switch ] else [])
      ]
  ;;
end

(* I've tried testing the following, which doesn't work as expected:

   {v
   let%expect_test "am_running_test" =
     print_s [%sexp { am_running_inline_test : bool; am_running_test : bool }];
     [%expect {| ((am_running_inline_test false) (am_running_test false)) |}];
     ()
   ;;
   v}

   Thus been using this variable to avoid the printer to produce styles in expect
   tests when running in the GitHub Actions environment.
*)
let force_am_running_test = ref false

module Message = struct
  module Kind = struct
    module T0 = struct
      [@@@coverage off]

      type t =
        | Error
        | Warning
        | Info
        | Debug
      [@@deriving equal, enumerate, sexp_of]
    end

    include T0

    let is_printed t ~(config : Config.t) =
      match (t : t) with
      | Error -> true
      | Warning -> config.warn_error || Config.Mode.compare config.mode Default >= 0
      | Info -> Config.Mode.compare config.mode Verbose >= 0
      | Debug -> Config.Mode.compare config.mode Debug >= 0
    ;;
  end

  type message = Stdune.User_message.t

  let sexp_of_message _ = Sexp.Atom "<opaque>"

  type t =
    { kind : Kind.t
    ; message : message
    ; mutable flushed : bool
    }
  [@@deriving sexp_of]

  let test_printer pp = Stdlib.prerr_string (Pp_extended.to_string pp)

  let print (t : t) ~config =
    if not t.flushed
    then (
      if Kind.is_printed t.kind ~config
      then (
        let use_test_printer = !force_am_running_test in
        Option.iter t.message.loc ~f:(fun loc ->
          (if use_test_printer then test_printer else Stdune.Ansi_color.prerr)
            (Stdune.Loc.pp loc
             |> Pp.map_tags ~f:(fun (Loc : Stdune.Loc.tag) ->
               Stdune.User_message.Print_config.default Loc)));
        let message = { t.message with loc = None } in
        if use_test_printer
        then test_printer (Stdune.User_message.pp message)
        else Stdune.User_message.prerr message);
      t.flushed <- true)
  ;;
end

type t =
  { config : Config.t
  ; messages : Message.t Queue.t
  }
[@@deriving sexp_of]

module Err = struct
  type t = T
end

exception E of Err.t

let reraise e = raise (E e)
let create ~config = { config; messages = Queue.create () }
let did_you_mean = Stdune.User_message.did_you_mean

let raise t ?loc ?hints paragraphs =
  let message = Stdune.User_error.make ?loc ?hints paragraphs in
  Queue.enqueue t.messages { kind = Error; message; flushed = false };
  reraise T
;;

let error t ?loc ?hints paragraphs =
  let message = Stdune.User_error.make ?loc ?hints paragraphs in
  Queue.enqueue t.messages { kind = Error; message; flushed = false }
;;

let warning t ?loc ?hints paragraphs =
  let message =
    let open Stdune in
    User_message.make
      ?loc
      ?hints
      ~prefix:
        (Pp.seq (Pp.tag User_message.Style.Warning (Pp.verbatim "Warning")) (Pp.char ':'))
      paragraphs
  in
  Queue.enqueue t.messages { kind = Warning; message; flushed = false }
;;

let info t ?loc ?hints paragraphs =
  let message =
    let open Stdune in
    User_message.make
      ?loc
      ?hints
      ~prefix:(Pp.seq (Pp.tag User_message.Style.Kwd (Pp.verbatim "Info")) (Pp.char ':'))
      paragraphs
  in
  Queue.enqueue t.messages { kind = Info; message; flushed = false }
;;

let debug t ?loc ?hints paragraphs =
  let message =
    let open Stdune in
    User_message.make
      ?loc
      ?hints
      ~prefix:
        (Pp.seq (Pp.tag User_message.Style.Debug (Pp.verbatim "Debug")) (Pp.char ':'))
      paragraphs
  in
  Queue.enqueue t.messages { kind = Debug; message; flushed = false }
;;

let special_error = Error.of_string "Aborted due to errors previously reported."

let flush { config; messages } =
  Queue.iter messages ~f:(fun message -> Message.print message ~config)
;;

let has_errors t =
  Queue.exists t.messages ~f:(fun m ->
    match m.kind with
    | Error -> true
    | Warning -> t.config.warn_error
    | Info | Debug -> false)
;;

let checkpoint (t : t) = if has_errors t then Error special_error else Ok ()
let checkpoint_exn (t : t) = if has_errors t then reraise T
let mode t = t.config.mode
let is_debug_mode t = Config.Mode.equal (mode t) Debug

let report_and_return_status ?(config = Config.default) f () =
  let t = create ~config in
  let status =
    match f t with
    | Ok () -> if has_errors t then `Fatal_error else `Ok
    | Error e -> `Error e
    | exception E T -> `Fatal_error
    | exception e ->
      let raw_backtrace = Stdlib.Printexc.get_raw_backtrace () in
      `Raised (e, raw_backtrace)
  in
  flush t;
  match status with
  | (`Ok | `Raised _) as status -> status
  | `Fatal_error -> `Error
  | `Error e ->
    if not (phys_equal e special_error) then prerr_endline (Error.to_string_hum e);
    `Error
;;

let report_and_exit ~config f () =
  match report_and_return_status ~config f () with
  | `Ok -> Stdlib.exit 0
  | `Error -> Stdlib.exit 1
  | `Raised (e, raw_backtrace) -> Stdlib.Printexc.raise_with_backtrace e raw_backtrace
;;

module For_test = struct
  let report ?config f =
    match
      Ref.set_temporarily force_am_running_test true ~f:(fun () ->
        report_and_return_status ?config f ())
    with
    | `Ok -> ()
    | `Error -> prerr_endline "[1]"
    | `Raised (e, raw_backtrace) -> Stdlib.Printexc.raise_with_backtrace e raw_backtrace
  ;;
end

let am_running_test () = !force_am_running_test

let protect _ ~f =
  match f () with
  | ok -> Ok ok
  | exception E e -> Error e
;;

1	open! Or_error.Let_syntax
2	module Style = Stdune.User_message.Style
3
4	(* We do [@@@coverage off] of ppx deriving constructs due to a generated
5	non visitable coverage point:
6
7	{[
8	let _ =
9	fun (_ : t) ->
10	___bisect_visit___ 0;
11	()
12	;;
13	]}
14
15	This is a known issue with work in progress to fix.
16
17	https://github.com/mbarbin/error-log/issues/1
18	*)
19
20	module Config = struct
21	module Mode = struct
22	module T0 = struct
23	[@@@coverage off]
24
25	type t =
26	\| Quiet
27	\| Default
28	\| Verbose
29	\| Debug
30	[@@deriving compare, equal, enumerate, sexp_of]
31	end
32
33	include T0
34
35	let switch t = "--" ^ (Sexp.to_string (sexp_of_t t) \|> String.uncapitalize)	36✔
36	end
37
38	module Warn_error = struct
39	module T0 = struct
40	[@@@coverage off]
41
42	type t = bool [@@deriving equal, sexp_of]
43	end
44
45	include T0
46
47	let switch = "--warn-error"
48	end
49
50	type t =	4✔
51	{ mode : Mode.t	4✔
52	; warn_error : Warn_error.t	4✔
53	}
54	[@@deriving equal, sexp_of]
55
56	let default = { mode = Default; warn_error = false }
57
58	let create ?(mode = default.mode) ?(warn_error = default.warn_error) () =	5✔
59	{ mode; warn_error }	19✔
60	;;
61
62	let param =
63	let open Command.Let_syntax in
64	let%map_open mode =
65	let verbose =
66	if%map
67	flag	10✔
68	(Mode.switch Verbose)	10✔
69	~aliases:[ "v"; "verbose" ]
70	no_arg
71	~doc:" print more messages"
72	then Some Mode.Verbose
73	else None
74	and debug =
75	if%map
76	flag	10✔
77	(Mode.switch Debug)	10✔
78	~aliases:[ "d"; "debug" ]
79	no_arg
80	~doc:" enable all messages including debug output"
81	then Some Mode.Debug
82	else None
83	and quiet =
84	if%map
85	flag	10✔
86	(Mode.switch Quiet)	10✔
87	~aliases:[ "q"; "-quiet" ]
88	no_arg
89	~doc:" suppress output except errors"
90	then Some Mode.Quiet
91	else None
92	in
93	choose_one [ debug; verbose; quiet ] ~if_nothing_chosen:(Default_to Mode.Default)	10✔
94	and warn_error =
95	if%map flag Warn_error.switch no_arg ~doc:" treat warnings as errors"	10✔
96	then true
97	else false
98	in
99	{ mode; warn_error }	16✔
100	;;
101
102	let to_params { mode; warn_error } =
103	List.concat	8✔
104	[ (match mode with
105	\| Default -> []	2✔
106	\| (Quiet \| Verbose \| Debug) as mode -> [ Mode.switch mode ])	2✔
107	; (if warn_error then [ Warn_error.switch ] else [])	4✔
108	]
109	;;
110	end
111
112	(* I've tried testing the following, which doesn't work as expected:
113
114	{v
115	let%expect_test "am_running_test" =
116	print_s [%sexp { am_running_inline_test : bool; am_running_test : bool }];
117	[%expect {\| ((am_running_inline_test false) (am_running_test false)) \|}];
118	()
119	;;
120	v}
121
122	Thus been using this variable to avoid the printer to produce styles in expect
123	tests when running in the GitHub Actions environment.
124	*)
125	let force_am_running_test = ref false
126
127	module Message = struct
128	module Kind = struct
129	module T0 = struct
130	[@@@coverage off]
131
132	type t =
133	\| Error
134	\| Warning
135	\| Info
136	\| Debug
137	[@@deriving equal, enumerate, sexp_of]
138	end
139
140	include T0
141
142	let is_printed t ~(config : Config.t) =
143	match (t : t) with	35✔
144	\| Error -> true	15✔
145	\| Warning -> config.warn_error \|\| Config.Mode.compare config.mode Default >= 0	3✔
146	\| Info -> Config.Mode.compare config.mode Verbose >= 0	6✔
147	\| Debug -> Config.Mode.compare config.mode Debug >= 0	6✔
148	;;
149	end
150
151	type message = Stdune.User_message.t
152
153	let sexp_of_message _ = Sexp.Atom "<opaque>"	7✔
154
155	type t =	7✔
156	{ kind : Kind.t	7✔
157	; message : message	7✔
158	; mutable flushed : bool	7✔
159	}
160	[@@deriving sexp_of]
161
162	let test_printer pp = Stdlib.prerr_string (Pp_extended.to_string pp)	44✔
163
164	let print (t : t) ~config =
165	if not t.flushed	39✔
166	then (	35✔
167	if Kind.is_printed t.kind ~config
168	then (	27✔
169	let use_test_printer = !force_am_running_test in
170	Option.iter t.message.loc ~f:(fun loc ->
171	(if use_test_printer then test_printer else Stdune.Ansi_color.prerr)	5✔
172	(Stdune.Loc.pp loc
173	\|> Pp.map_tags ~f:(fun (Loc : Stdune.Loc.tag) ->	27✔
174	Stdune.User_message.Print_config.default Loc)));	27✔
175	let message = { t.message with loc = None } in	27✔
176	if use_test_printer
177	then test_printer (Stdune.User_message.pp message)	22✔
178	else Stdune.User_message.prerr message);	5✔
179	t.flushed <- true)	35✔
180	;;
181	end
182
183	type t =	3✔
184	{ config : Config.t	3✔
185	; messages : Message.t Queue.t	3✔
186	}
187	[@@deriving sexp_of]
188
189	module Err = struct
190	type t = T
191	end
192
193	exception E of Err.t
194
195	let reraise e = raise (E e)	6✔
196	let create ~config = { config; messages = Queue.create () }	30✔
197	let did_you_mean = Stdune.User_message.did_you_mean
198
199	let raise t ?loc ?hints paragraphs =
200	let message = Stdune.User_error.make ?loc ?hints paragraphs in	4✔
201	Queue.enqueue t.messages { kind = Error; message; flushed = false };	4✔
202	reraise T	4✔
203	;;
204
205	let error t ?loc ?hints paragraphs =
206	let message = Stdune.User_error.make ?loc ?hints paragraphs in	11✔
207	Queue.enqueue t.messages { kind = Error; message; flushed = false }	11✔
208	;;
209
210	let warning t ?loc ?hints paragraphs =
211	let message =	8✔
212	let open Stdune in
213	User_message.make	8✔
214	?loc
215	?hints
216	~prefix:
217	(Pp.seq (Pp.tag User_message.Style.Warning (Pp.verbatim "Warning")) (Pp.char ':'))	8✔
218	paragraphs
219	in
220	Queue.enqueue t.messages { kind = Warning; message; flushed = false }
221	;;
222
223	let info t ?loc ?hints paragraphs =
224	let message =	6✔
225	let open Stdune in
226	User_message.make	6✔
227	?loc
228	?hints
229	~prefix:(Pp.seq (Pp.tag User_message.Style.Kwd (Pp.verbatim "Info")) (Pp.char ':'))	6✔
230	paragraphs
231	in
232	Queue.enqueue t.messages { kind = Info; message; flushed = false }
233	;;
234
235	let debug t ?loc ?hints paragraphs =
236	let message =	6✔
237	let open Stdune in
238	User_message.make	6✔
239	?loc
240	?hints
241	~prefix:
242	(Pp.seq (Pp.tag User_message.Style.Debug (Pp.verbatim "Debug")) (Pp.char ':'))	6✔
243	paragraphs
244	in
245	Queue.enqueue t.messages { kind = Debug; message; flushed = false }
246	;;
247
248	let special_error = Error.of_string "Aborted due to errors previously reported."	10✔
249
250	let flush { config; messages } =
251	Queue.iter messages ~f:(fun message -> Message.print message ~config)	32✔
252	;;
253
254	let has_errors t =
255	Queue.exists t.messages ~f:(fun m ->	27✔
256	match m.kind with	24✔
257	\| Error -> true	7✔
258	\| Warning -> t.config.warn_error	7✔
259	\| Info \| Debug -> false)	5✔
260	;;
261
262	let checkpoint (t : t) = if has_errors t then Error special_error else Ok ()	1✔
263	let checkpoint_exn (t : t) = if has_errors t then reraise T	1✔
264	let mode t = t.config.mode	4✔
265	let is_debug_mode t = Config.Mode.equal (mode t) Debug	2✔
266
267	let report_and_return_status ?(config = Config.default) f () =	12✔
268	let t = create ~config in	30✔
269	let status =
270	match f t with
271	\| Ok () -> if has_errors t then `Fatal_error else `Ok	9✔
272	\| Error e -> `Error e	2✔
273	\| exception E T -> `Fatal_error	3✔
274	\| exception e ->	2✔
275	let raw_backtrace = Stdlib.Printexc.get_raw_backtrace () in
276	`Raised (e, raw_backtrace)	2✔
277	in
278	flush t;
279	match status with	30✔
280	\| (`Ok \| `Raised _) as status -> status	2✔
281	\| `Fatal_error -> `Error	12✔
282	\| `Error e ->	2✔
283	if not (phys_equal e special_error) then prerr_endline (Error.to_string_hum e);	1✔
284	`Error	2✔
285	;;
286
287	let report_and_exit ~config f () =
288	match report_and_return_status ~config f () with	8✔
289	\| `Ok -> Stdlib.exit 0	5✔
290	\| `Error -> Stdlib.exit 1	2✔
291	\| `Raised (e, raw_backtrace) -> Stdlib.Printexc.raise_with_backtrace e raw_backtrace	1✔
292	;;
293
294	module For_test = struct
295	let report ?config f =
296	match	22✔
297	Ref.set_temporarily force_am_running_test true ~f:(fun () ->
298	report_and_return_status ?config f ())	22✔
299	with
300	\| `Ok -> ()	9✔
301	\| `Error -> prerr_endline "[1]"	12✔
302	\| `Raised (e, raw_backtrace) -> Stdlib.Printexc.raise_with_backtrace e raw_backtrace	1✔
303	;;
304	end
305
NEW 306	let am_running_test () = !force_am_running_test	×
307
308	let protect _ ~f =
309	match f () with	3✔
310	\| ok -> Ok ok	1✔
311	\| exception E e -> Error e	1✔
312	;;

mbarbin / error-log / 25

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous