mbarbin / error-log / 54

Committed 23 Aug 2024 07:43PM UTC coverage: 99.683% (-0.3%) from 100.0%

Build # 54

Build Type

push

github

Committed by

web-flow

Commit Message

Merge pull request #8 from mbarbin/reduce-deps

Upgrade err0, loc0 and reducing dependencies

Run Details

13 of 13 new or added lines in 2 files covered. (100.0%)

1 existing line in 1 file now uncovered.

314 of 315 relevant lines covered (99.68%)

5.01 hits per line

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

99.14

/src/error_log.ml

module Style = Stdune.User_message.Style

module Config = struct
  module Mode = struct
    type t =
      | Quiet
      | Default
      | Verbose
      | Debug
    [@@deriving compare, equal, enumerate, sexp_of]

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

  module Warn_error = struct
    type t = bool [@@deriving equal, sexp_of]

    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 arg =
    let%map_open.Command mode =
      let%map.Command verbose =
        if%map.Command Arg.flag [ Mode.switch Verbose; "v" ] ~doc:"print more messages"
        then Some Mode.Verbose
        else None
      and debug =
        if%map.Command
          Arg.flag
            [ Mode.switch Debug; "d" ]
            ~doc:"enable all messages including debug output"
        then Some Mode.Debug
        else None
      and quiet =
        if%map.Command
          Arg.flag [ Mode.switch Quiet; "q" ] ~doc:"suppress output except errors"
        then Some Mode.Quiet
        else None
      in
      [ debug; verbose; quiet ]
      |> List.filter_opt
      |> List.max_elt ~compare:Mode.compare
      |> Option.value ~default:Mode.Default
    and warn_error =
      if%map.Command Arg.flag [ Warn_error.switch ] ~doc:"treat warnings as errors"
      then true
      else false
    in
    { mode; warn_error }
  ;;

  let to_args { 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
    type t =
      | Error
      | Warning
      | Info
      | Debug
    [@@deriving equal, enumerate, sexp_of]

    let to_string t =
      match sexp_of_t t with
      | Atom atom -> atom |> String.uncapitalize
      | List _ -> assert false
    ;;

    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 =
    Stdune.User_message.make
      ?loc
      ?hints
      ~prefix:
        (Pp.seq
           (Pp.tag Stdune.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 =
    Stdune.User_message.make
      ?loc
      ?hints
      ~prefix:
        (Pp.seq (Pp.tag Stdune.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 =
    Stdune.User_message.make
      ?loc
      ?hints
      ~prefix:
        (Pp.seq
           (Pp.tag Stdune.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 Stdlib.prerr_endline (Error.to_string_hum e);
    `Error
;;

let report_and_exit ~config f =
  match report_and_return_status ~config f with
  | `Ok ->
    (* We allow the function to terminate normally when [code=0]. This is
       because [bisect_ppx] instruments the out-edge of calls to [run] in
       executables. If we never return, it would create false negatives in test
       coverage. We may revisit this decision in the future if the context
       changes. *)
    ()
  | `Error -> Stdlib.exit 1
  | `Raised (e, raw_backtrace) -> Stdlib.Printexc.raise_with_backtrace e raw_backtrace
;;

let report_and_exit' ~config f =
  report_and_exit ~config (fun t ->
    f t;
    Ok ())
;;

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 -> Stdlib.prerr_endline "[1]"
    | `Raised (e, raw_backtrace) -> Stdlib.Printexc.raise_with_backtrace e raw_backtrace
  ;;

  let report' ?config f =
    report ?config (fun t ->
      f t;
      Ok ())
  ;;
end

let am_running_test () = !force_am_running_test

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

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

mbarbin / error-log / 54

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