mbarbin / pplumbing / 46

Committed 22 May 2025 09:13AM UTC coverage: 95.97% (-0.09%) from 96.06%

Build # 46

Build Type

push

github

Committed by

web-flow

Commit Message

Merge pull request #11 from mbarbin/improve-context-rendering

Improve context rendering

Coverage Stats

9 of 10 new or added lines in 1 file covered. (90.0%)

905 of 943 relevant lines covered (95.97%)

10.01 hits per line

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

99.58

/lib/err/src/err.ml

(*********************************************************************************)
(*  pplumbing - Utility libraries to use with [pp]                               *)
(*  SPDX-FileCopyrightText: 2024-2025 Mathieu Barbin <mathieu.barbin@gmail.com>  *)
(*  SPDX-License-Identifier: MIT                                                 *)
(*********************************************************************************)

module List = struct
  include List

  (* Not available with OCaml 4.14. *)
  let is_empty = function
    | [] -> true
    | _ :: _ -> false
  ;;
end

module Exit_code = struct
  type t = int

  let ok = 0
  let some_error = 123
  let cli_error = 124
  let internal_error = 125
end

let sexp sexp = Pp.verbatim (Sexplib0.Sexp.to_string_hum sexp)
let exn e = sexp (Sexplib0.Sexp_conv.sexp_of_exn e)

module Paragraph = struct
  type t = Pp_tty.t

  let recognize_sexp t =
    match Pp.to_ast t with
    | Verbatim str ->
      (match Parsexp.Single.parse_string str with
       | Ok sexp -> Some sexp
       | Error _ -> None)
    | _ -> None
  ;;

  let sexp_of_t t =
    match recognize_sexp t with
    | Some sexp -> sexp
    | None ->
      let str = Format.asprintf "%a" Pp.to_fmt (Pp.hbox t) in
      Sexplib0.Sexp.Atom str
  ;;

  let rec simplify_sexp sexp =
    match (sexp : Sexplib0.Sexp.t) with
    | (Atom _ | List []) as sexp -> sexp
    | List [ sexp ] -> simplify_sexp sexp
    | List [ (Atom str as atom); List (List _ :: _ as sexps) ]
      when not (String.contains str ' ') -> List (atom :: List.map simplify_sexp sexps)
    | List sexps -> List (List.map simplify_sexp sexps)
  ;;

  let default_sexp_rendering = sexp

  (* Future plans involve coloring the sexps when rendering to the console. *)
  let pp_sexp sexp =
    let sexp = simplify_sexp sexp in
    let pp =
      (* This is an heuristic to improve the rendering of errors built with the
         [%sexp] extension, such as:

         {[
           [%sexp "Error message", { fields }]
         }]
      *)
      match (sexp : Sexplib0.Sexp.t) with
      | List (Atom atom :: (List _ :: _ as sexps)) when String.contains atom ' ' ->
        Pp.O.(
          Pp.verbatim atom ++ Pp.space ++ Pp.concat_map sexps ~f:default_sexp_rendering)
      | sexp -> default_sexp_rendering sexp
    in
    Pp.box pp
  ;;

  let pp t =
    match recognize_sexp t with
    | Some sexp -> pp_sexp sexp
    | None -> t
  ;;
end

module Level = struct
  type t =
    | Error
    | Warning
    | Info
    | Debug

  let sexp_of_t : t -> Sexplib0.Sexp.t = function
    | Error -> Atom "Error"
    | Warning -> Atom "Warning"
    | Info -> Atom "Info"
    | Debug -> Atom "Debug"
  ;;

  let all = [ Error; Warning; Info; Debug ]

  let to_index = function
    | Error -> 0
    | Warning -> 1
    | Info -> 2
    | Debug -> 3
  ;;

  let compare l1 l2 = Int.compare (to_index l1) (to_index l2)
  let equal l1 l2 = Int.equal (to_index l1) (to_index l2)

  let to_string = function
    | Error -> "error"
    | Warning -> "warning"
    | Info -> "info"
    | Debug -> "debug"
  ;;

  let style : t -> Pp_tty.Style.t = function
    | Error -> Error
    | Warning -> Warning
    | Info -> Kwd
    | Debug -> Debug
  ;;
end

let stdune_loc (loc : Loc.t) =
  let { Loc.Lexbuf_loc.start; stop } = Loc.to_lexbuf_loc loc in
  Stdune.Loc.of_lexbuf_loc { start; stop }
;;

let with_prefix ~prefix ~(style : Pp_tty.Style.t) paragraphs =
  let prefix = Pp.seq (Pp.tag style (Pp.verbatim prefix)) (Pp.char ':') in
  match List.map Paragraph.pp paragraphs with
  | [] -> [ prefix ]
  | x :: tl -> Pp.concat ~sep:Pp.space [ prefix; x ] :: tl
;;

let make_message ~level ?loc ?(context = []) ?(hints = []) paragraphs =
  Stdune.User_message.make
    ?loc:(Option.map stdune_loc loc)
    ~hints
    ?prefix:None
    (List.concat
       [ (match context with
          | [] -> []
          | _ :: _ as context -> with_prefix ~prefix:"Context" ~style:Kwd context)
       ; with_prefix
           ~prefix:(Level.to_string level |> String.capitalize_ascii)
           ~style:(Level.style level)
           paragraphs
       ])
;;

type t =
  { loc : Loc.t option
  ; context : Paragraph.t list
  ; paragraphs : Paragraph.t list
  ; hints : Pp_tty.t list
  ; exit_code : Exit_code.t
  }

let to_sexps { loc; context; paragraphs; hints; exit_code = _ } =
  List.concat
    [ (match loc with
       | None -> []
       | Some loc ->
         if Loc.include_sexp_of_locs.contents
         then [ Sexplib0.Sexp.Atom (Loc.to_string loc) ]
         else [])
    ; (if List.is_empty context
       then List.map Paragraph.sexp_of_t paragraphs
       else
         [ List (Atom "context" :: List.map Paragraph.sexp_of_t context)
         ; List (Atom "error" :: List.map Paragraph.sexp_of_t paragraphs)
         ])
    ; (match hints with
       | [] -> []
       | _ :: _ -> [ List (Atom "hints" :: List.map Paragraph.sexp_of_t hints) ])
    ]
;;

let to_stdune_user_message ~level { loc; context; paragraphs; hints; exit_code = _ } =
  if
    List.is_empty paragraphs
    && Option.is_none loc
    && List.is_empty context
    && List.is_empty hints
  then None
  else Some (make_message ~level ?loc ~context ~hints paragraphs)
;;

let sexp_of_t_internal ~include_exit_code t =
  let sexps = to_sexps t in
  let list =
    List.concat
      [ sexps
      ; (if include_exit_code || List.is_empty sexps
         then [ List [ Atom "exit_code"; Atom (Int.to_string t.exit_code) ] ]
         else [])
      ]
  in
  match list with
  | [ sexp ] -> sexp
  | _ -> Sexplib0.Sexp.List list
;;

let sexp_of_t t = sexp_of_t_internal ~include_exit_code:false t
let to_string_hum t = Sexplib0.Sexp.to_string_hum (sexp_of_t t)

module With_exit_code = struct
  type nonrec t = t

  let sexp_of_t t = sexp_of_t_internal ~include_exit_code:true t
end

exception E of t

let () =
  Sexplib0.Sexp_conv.Exn_converter.add [%extension_constructor E] (function
    | E t -> sexp_of_t t
    | _ -> assert false)
;;

let create
      ?loc
      ?(context = [])
      ?(hints = [])
      ?(exit_code = Exit_code.some_error)
      paragraphs
  =
  { loc; context; paragraphs; hints; exit_code }
;;

let add_context t context = { t with context = context @ t.context }

let raise ?loc ?hints ?exit_code paragraphs =
  Stdlib.raise (E (create ?loc ?hints ?exit_code paragraphs))
;;

let reraise_with_context t bt context =
  Printexc.raise_with_backtrace (E (add_context t context)) bt
;;

let exit exit_code =
  Stdlib.raise (E { loc = None; context = []; paragraphs = []; hints = []; exit_code })
;;

let ok_exn = function
  | Ok x -> x
  | Error e -> Stdlib.raise (E e)
;;

let of_exn e =
  match (e : exn) with
  | E e -> e
  | e -> create [ exn e ]
;;

let did_you_mean = Stdune.User_message.did_you_mean

module Color_mode = struct
  type t =
    [ `Auto
    | `Always
    | `Never
    ]

  let sexp_of_t : t -> Sexplib0.Sexp.t = function
    | `Auto -> Atom "Auto"
    | `Always -> Atom "Always"
    | `Never -> Atom "Never"
  ;;

  let all : t list = [ `Auto; `Always; `Never ]

  let to_index = function
    | `Auto -> 0
    | `Always -> 1
    | `Never -> 2
  ;;

  let compare l1 l2 = Int.compare (to_index l1) (to_index l2)
  let equal l1 l2 = Int.equal (to_index l1) (to_index l2)

  let to_string : t -> string = function
    | `Auto -> "auto"
    | `Always -> "always"
    | `Never -> "never"
  ;;
end

let color_mode_value : Color_mode.t ref = ref `Auto
let color_mode () = !color_mode_value

(* 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 am_running_test_value = ref false
let am_running_test () = !am_running_test_value
let log_err_count_value = ref (fun () -> (0 [@coverage off]))
let log_warn_count_value = ref (fun () -> (0 [@coverage off]))
let error_count_value = ref 0
let warning_count_value = ref 0

let error_count () =
  if am_running_test ()
  then !error_count_value
  else !error_count_value + log_err_count_value.contents ()
;;

let had_errors () = error_count () > 0

let warning_count () =
  if am_running_test ()
  then !warning_count_value
  else !warning_count_value + log_warn_count_value.contents ()
;;

let no_style_printer pp = Stdlib.prerr_string (Format.asprintf "%a" Pp.to_fmt pp)
let include_separator = ref false

let reset_counts () =
  error_count_value := 0;
  warning_count_value := 0
;;

let reset_separator () = include_separator := false

let prerr_message (t : Stdune.User_message.t) =
  let use_no_style_printer =
    !am_running_test_value
    ||
    match !color_mode_value with
    | `Never -> true
    | `Always | `Auto -> false
  in
  let () =
    if !include_separator then Stdlib.prerr_newline () else include_separator := true
  in
  t.loc
  |> Option.iter (fun loc ->
    (if use_no_style_printer then no_style_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 with loc = None } in
  if use_no_style_printer
  then no_style_printer (Stdune.User_message.pp message)
  else Stdune.User_message.prerr message
;;

let prerr ?(reset_separator = false) (t : t) =
  if reset_separator then include_separator := false;
  Option.iter prerr_message (to_stdune_user_message ~level:Error t)
;;

module Log_level = struct
  type t =
    | Quiet
    | App
    | Error
    | Warning
    | Info
    | Debug

  let sexp_of_t : t -> Sexplib0.Sexp.t = function
    | Quiet -> Atom "Quiet"
    | App -> Atom "App"
    | Error -> Atom "Error"
    | Warning -> Atom "Warning"
    | Info -> Atom "Info"
    | Debug -> Atom "Debug"
  ;;

  let all = [ Quiet; App; Error; Warning; Info; Debug ]

  let to_index = function
    | Quiet -> 0
    | App -> 1
    | Error -> 2
    | Warning -> 3
    | Info -> 4
    | Debug -> 5
  ;;

  let compare l1 l2 = Int.compare (to_index l1) (to_index l2)
  let equal l1 l2 = Int.equal (to_index l1) (to_index l2)

  let of_level (level : Level.t) : t =
    match level with
    | Error -> Error
    | Warning -> Warning
    | Info -> Info
    | Debug -> Debug
  ;;

  let to_string = function
    | Quiet -> "quiet"
    | App -> "app"
    | Error -> "error"
    | Warning -> "warning"
    | Info -> "info"
    | Debug -> "debug"
  ;;
end

let warn_error_value = ref false

let log_level_get_value, log_level_set_value =
  let value = ref Log_level.Warning in
  ref (fun () -> (!value [@coverage off])), ref (fun v -> value := (v [@coverage off]))
;;

let log_level () = log_level_get_value.contents ()
let log_enables ~level = Log_level.compare (log_level ()) (Log_level.of_level level) >= 0

let error ?loc ?hints paragraphs =
  incr error_count_value;
  if log_enables ~level:Error
  then (
    let message = make_message ~level:Error ?loc ?hints paragraphs in
    prerr_message message)
;;

let warning ?loc ?hints paragraphs =
  incr warning_count_value;
  if log_enables ~level:Warning
  then (
    let message = make_message ~level:Warning ?loc ?hints paragraphs in
    prerr_message message)
;;

let info ?loc ?hints paragraphs =
  if log_enables ~level:Info
  then (
    let message = make_message ~level:Info ?loc ?hints paragraphs in
    prerr_message message)
;;

let debug ?loc ?hints paragraphs =
  if log_enables ~level:Debug
  then (
    let message = make_message ~level:Debug ?loc ?hints (Lazy.force paragraphs) in
    prerr_message message)
;;

let emit t ~level =
  (match (level : Level.t) with
   | Error -> incr error_count_value
   | Warning -> incr warning_count_value
   | Info | Debug -> ());
  if log_enables ~level then Option.iter prerr_message (to_stdune_user_message t ~level)
;;

let pp_backtrace backtrace =
  if am_running_test ()
  then [ "<backtrace disabled in tests>" ]
  else
    String.split_on_char '\n' (Printexc.raw_backtrace_to_string backtrace)
    |> List.filter (fun s -> not (String.length s = 0))
;;

let handle_messages_and_exit ~err:({ exit_code; _ } as t) ~backtrace =
  if log_enables ~level:Error
  then (
    Option.iter prerr_message (to_stdune_user_message ~level:Error t);
    if Int.equal exit_code Exit_code.internal_error
    then (
      let message =
        let prefix = Pp.seq (Pp_tty.tag Error (Pp.verbatim "Backtrace")) (Pp.char ':') in
        let backtrace = pp_backtrace backtrace in
        Stdune.User_message.make
          ~prefix
          [ Pp.concat_map ~sep:(Pp.break ~nspaces:1 ~shift:0) backtrace ~f:Pp.verbatim ]
      in
      prerr_message message));
  Error exit_code
;;

let had_errors_or_warn_errors () =
  error_count () > 0 || (!warn_error_value && warning_count () > 0)
;;

let protect ?(exn_handler = Fun.const None) f =
  reset_counts ();
  reset_separator ();
  match f () with
  | ok -> if had_errors_or_warn_errors () then Error Exit_code.some_error else Ok ok
  | exception E err ->
    let backtrace = Printexc.get_raw_backtrace () in
    handle_messages_and_exit ~err ~backtrace
  | exception exn ->
    let backtrace = Printexc.get_raw_backtrace () in
    (match exn_handler exn with
     | Some err -> handle_messages_and_exit ~err ~backtrace
     | None ->
       if log_enables ~level:Error
       then (
         let message =
           let prefix =
             Pp.seq (Pp_tty.tag Error (Pp.verbatim "Internal Error")) (Pp.char ':')
           in
           let backtrace = pp_backtrace backtrace in
           Stdune.User_message.make
             ~prefix
             [ Pp.concat_map
                 ~sep:(Pp.break ~nspaces:1 ~shift:0)
                 (Printexc.to_string exn :: backtrace)
                 ~f:Pp.verbatim
             ]
         in
         prerr_message message);
       Error Exit_code.internal_error)
;;

module For_test = struct
  let wrap f =
    let init = am_running_test () in
    am_running_test_value := true;
    let init_level = log_level_get_value.contents () in
    log_level_set_value.contents Log_level.Warning;
    Fun.protect
      ~finally:(fun () ->
        am_running_test_value := init;
        log_level_set_value.contents init_level)
      f
  ;;

  let protect ?exn_handler f =
    match wrap (fun () -> protect f ?exn_handler) with
    | Ok () -> ()
    | Error code -> if code <> 0 then Stdlib.prerr_endline (Printf.sprintf "[%d]" code)
  ;;
end

module Private = struct
  let am_running_test = am_running_test_value

  let reset_counts () =
    error_count_value := 0;
    warning_count_value := 0
  ;;

  let reset_separator () = include_separator := false
  let color_mode = color_mode_value

  let set_log_level ~get ~set =
    log_level_get_value := get;
    log_level_set_value := set;
    ()
  ;;

  let warn_error = warn_error_value

  let set_log_counts ~err_count ~warn_count =
    log_err_count_value := err_count;
    log_warn_count_value := warn_count;
    ()
  ;;
end

let create_s ?loc ?hints ?exit_code desc s =
  create ?loc ?hints ?exit_code [ Pp.text desc; sexp s ] [@coverage off]
;;

let raise_s ?loc ?hints ?exit_code desc s =
  raise ?loc ?hints ?exit_code [ Pp.text desc; sexp s ] [@coverage off]
;;

let reraise_s bt e ?loc:_ ?hints:_ ?exit_code:_ desc s =
  reraise_with_context e bt [ Pp.text desc; sexp s ] [@coverage off]
;;

let pp_of_sexp = sexp

1	(*********************************************************************************)
2	(* pplumbing - Utility libraries to use with [pp] *)
3	(* SPDX-FileCopyrightText: 2024-2025 Mathieu Barbin <mathieu.barbin@gmail.com> *)
4	(* SPDX-License-Identifier: MIT *)
5	(*********************************************************************************)
6
7	module List = struct
8	include List
9
10	(* Not available with OCaml 4.14. *)
11	let is_empty = function
12	\| [] -> true	50✔
13	\| _ :: _ -> false	61✔
14	;;
15	end
16
17	module Exit_code = struct
18	type t = int
19
20	let ok = 0
21	let some_error = 123
22	let cli_error = 124
23	let internal_error = 125
24	end
25
26	let sexp sexp = Pp.verbatim (Sexplib0.Sexp.to_string_hum sexp)	32✔
27	let exn e = sexp (Sexplib0.Sexp_conv.sexp_of_exn e)	1✔
28
29	module Paragraph = struct
30	type t = Pp_tty.t
31
32	let recognize_sexp t =
33	match Pp.to_ast t with	123✔
34	\| Verbatim str ->	33✔
35	(match Parsexp.Single.parse_string str with
36	\| Ok sexp -> Some sexp	27✔
37	\| Error _ -> None)	6✔
38	\| _ -> None	90✔
39	;;
40
41	let sexp_of_t t =
42	match recognize_sexp t with	30✔
43	\| Some sexp -> sexp	12✔
44	\| None ->	18✔
45	let str = Format.asprintf "%a" Pp.to_fmt (Pp.hbox t) in	18✔
46	Sexplib0.Sexp.Atom str	18✔
47	;;
48
49	let rec simplify_sexp sexp =
50	match (sexp : Sexplib0.Sexp.t) with	78✔
51	\| (Atom _ \| List []) as sexp -> sexp	1✔
52	\| List [ sexp ] -> simplify_sexp sexp	6✔
53	\| List [ (Atom str as atom); List (List _ :: _ as sexps) ]	5✔
54	when not (String.contains str ' ') -> List (atom :: List.map simplify_sexp sexps)	1✔
55	\| List sexps -> List (List.map simplify_sexp sexps)	27✔
56	;;
57
58	let default_sexp_rendering = sexp
59
60	(* Future plans involve coloring the sexps when rendering to the console. *)
61	let pp_sexp sexp =
62	let sexp = simplify_sexp sexp in	15✔
63	let pp =	15✔
64	(* This is an heuristic to improve the rendering of errors built with the
65	[%sexp] extension, such as:
66
67	{[
68	[%sexp "Error message", { fields }]
69	}]
70	*)
71	match (sexp : Sexplib0.Sexp.t) with
72	\| List (Atom atom :: (List _ :: _ as sexps)) when String.contains atom ' ' ->	5✔
73	Pp.O.(	4✔
74	Pp.verbatim atom ++ Pp.space ++ Pp.concat_map sexps ~f:default_sexp_rendering)	4✔
75	\| sexp -> default_sexp_rendering sexp	11✔
76	in
77	Pp.box pp
78	;;
79
80	let pp t =
81	match recognize_sexp t with	93✔
82	\| Some sexp -> pp_sexp sexp	15✔
83	\| None -> t	78✔
84	;;
85	end
86
87	module Level = struct
88	type t =
89	\| Error
90	\| Warning
91	\| Info
92	\| Debug
93
94	let sexp_of_t : t -> Sexplib0.Sexp.t = function
95	\| Error -> Atom "Error"	1✔
96	\| Warning -> Atom "Warning"	1✔
97	\| Info -> Atom "Info"	1✔
98	\| Debug -> Atom "Debug"	1✔
99	;;
100
101	let all = [ Error; Warning; Info; Debug ]
102
103	let to_index = function
104	\| Error -> 0	7✔
105	\| Warning -> 1	6✔
106	\| Info -> 2	4✔
107	\| Debug -> 3	5✔
108	;;
109
110	let compare l1 l2 = Int.compare (to_index l1) (to_index l2)	6✔
111	let equal l1 l2 = Int.equal (to_index l1) (to_index l2)	5✔
112
113	let to_string = function
114	\| Error -> "error"	79✔
115	\| Warning -> "warning"	36✔
116	\| Info -> "info"	26✔
117	\| Debug -> "debug"	24✔
118	;;
119
120	let style : t -> Pp_tty.Style.t = function
121	\| Error -> Error	56✔
122	\| Warning -> Warning	15✔
123	\| Info -> Kwd	5✔
124	\| Debug -> Debug	3✔
125	;;
126	end
127
128	let stdune_loc (loc : Loc.t) =
129	let { Loc.Lexbuf_loc.start; stop } = Loc.to_lexbuf_loc loc in	30✔
130	Stdune.Loc.of_lexbuf_loc { start; stop }	30✔
131	;;
132
133	let with_prefix ~prefix ~(style : Pp_tty.Style.t) paragraphs =
134	let prefix = Pp.seq (Pp.tag style (Pp.verbatim prefix)) (Pp.char ':') in	85✔
135	match List.map Paragraph.pp paragraphs with	85✔
NEW 136	\| [] -> [ prefix ]	×
137	\| x :: tl -> Pp.concat ~sep:Pp.space [ prefix; x ] :: tl	85✔
138	;;
139
140	let make_message ~level ?loc ?(context = []) ?(hints = []) paragraphs =	40✔
141	Stdune.User_message.make	79✔
142	?loc:(Option.map stdune_loc loc)	79✔
143	~hints
144	?prefix:None
145	(List.concat	79✔
146	[ (match context with
147	\| [] -> []	73✔
148	\| _ :: _ as context -> with_prefix ~prefix:"Context" ~style:Kwd context)	6✔
149	; with_prefix	79✔
150	~prefix:(Level.to_string level \|> String.capitalize_ascii)	79✔
151	~style:(Level.style level)	79✔
152	paragraphs
153	])
154	;;
155
156	type t =
157	{ loc : Loc.t option
158	; context : Paragraph.t list
159	; paragraphs : Paragraph.t list
160	; hints : Pp_tty.t list
161	; exit_code : Exit_code.t
162	}
163
164	let to_sexps { loc; context; paragraphs; hints; exit_code = _ } =
165	List.concat	23✔
166	[ (match loc with
167	\| None -> []	19✔
168	\| Some loc ->	4✔
169	if Loc.include_sexp_of_locs.contents
170	then [ Sexplib0.Sexp.Atom (Loc.to_string loc) ]	1✔
171	else [])	3✔
172	; (if List.is_empty context
173	then List.map Paragraph.sexp_of_t paragraphs	21✔
174	else
175	[ List (Atom "context" :: List.map Paragraph.sexp_of_t context)	2✔
176	; List (Atom "error" :: List.map Paragraph.sexp_of_t paragraphs)	2✔
177	])
178	; (match hints with
179	\| [] -> []	19✔
180	\| _ :: _ -> [ List (Atom "hints" :: List.map Paragraph.sexp_of_t hints) ])	4✔
181	]
182	;;
183
184	let to_stdune_user_message ~level { loc; context; paragraphs; hints; exit_code = _ } =
185	if	48✔
186	List.is_empty paragraphs	48✔
187	&& Option.is_none loc	9✔
188	&& List.is_empty context	9✔
189	&& List.is_empty hints	9✔
190	then None	9✔
191	else Some (make_message ~level ?loc ~context ~hints paragraphs)	39✔
192	;;
193
194	let sexp_of_t_internal ~include_exit_code t =
195	let sexps = to_sexps t in	23✔
196	let list =	23✔
197	List.concat
198	[ sexps
199	; (if include_exit_code \|\| List.is_empty sexps	1✔
200	then [ List [ Atom "exit_code"; Atom (Int.to_string t.exit_code) ] ]	3✔
201	else [])	20✔
202	]
203	in
204	match list with	23✔
205	\| [ sexp ] -> sexp	16✔
206	\| _ -> Sexplib0.Sexp.List list	7✔
207	;;
208
209	let sexp_of_t t = sexp_of_t_internal ~include_exit_code:false t	22✔
210	let to_string_hum t = Sexplib0.Sexp.to_string_hum (sexp_of_t t)	1✔
211
212	module With_exit_code = struct
213	type nonrec t = t
214
215	let sexp_of_t t = sexp_of_t_internal ~include_exit_code:true t	1✔
216	end
217
218	exception E of t
219
220	let () =
221	Sexplib0.Sexp_conv.Exn_converter.add [%extension_constructor E] (function	29✔
222	\| E t -> sexp_of_t t	5✔
223	\| _ -> assert false)
224	;;
225
226	let create
227	?loc
228	?(context = [])	46✔
229	?(hints = [])	36✔
230	?(exit_code = Exit_code.some_error)	43✔
231	paragraphs
232	=
233	{ loc; context; paragraphs; hints; exit_code }	46✔
234	;;
235
236	let add_context t context = { t with context = context @ t.context }	6✔
237
238	let raise ?loc ?hints ?exit_code paragraphs =
239	Stdlib.raise (E (create ?loc ?hints ?exit_code paragraphs))	12✔
240	;;
241
242	let reraise_with_context t bt context =
243	Printexc.raise_with_backtrace (E (add_context t context)) bt	2✔
244	;;
245
246	let exit exit_code =
247	Stdlib.raise (E { loc = None; context = []; paragraphs = []; hints = []; exit_code })	13✔
248	;;
249
250	let ok_exn = function
251	\| Ok x -> x	1✔
252	\| Error e -> Stdlib.raise (E e)	1✔
253	;;
254
255	let of_exn e =
256	match (e : exn) with	2✔
257	\| E e -> e	1✔
258	\| e -> create [ exn e ]	1✔
259	;;
260
261	let did_you_mean = Stdune.User_message.did_you_mean
262
263	module Color_mode = struct
264	type t =
265	[ `Auto
266	\| `Always
267	\| `Never
268	]
269
270	let sexp_of_t : t -> Sexplib0.Sexp.t = function
271	\| `Auto -> Atom "Auto"	1✔
272	\| `Always -> Atom "Always"	1✔
273	\| `Never -> Atom "Never"	1✔
274	;;
275
276	let all : t list = [ `Auto; `Always; `Never ]
277
278	let to_index = function
279	\| `Auto -> 0	8✔
280	\| `Always -> 1	8✔
281	\| `Never -> 2	8✔
282	;;
283
284	let compare l1 l2 = Int.compare (to_index l1) (to_index l2)	5✔
285	let equal l1 l2 = Int.equal (to_index l1) (to_index l2)	7✔
286
287	let to_string : t -> string = function
288	\| `Auto -> "auto"	29✔
289	\| `Always -> "always"	29✔
290	\| `Never -> "never"	29✔
291	;;
292	end
293
294	let color_mode_value : Color_mode.t ref = ref `Auto
295	let color_mode () = !color_mode_value	3✔
296
297	(* I've tried testing the following, which doesn't work as expected:
298
299	{v
300	let%expect_test "am_running_test" =
301	print_s [%sexp { am_running_inline_test : bool; am_running_test : bool }];
302	[%expect {\| ((am_running_inline_test false) (am_running_test false)) \|}];
303	()
304	;;
305	v}
306
307	Thus been using this variable to avoid the printer to produce styles in expect
308	tests when running in the GitHub Actions environment.
309	*)
310	let am_running_test_value = ref false
311	let am_running_test () = !am_running_test_value	203✔
312	let log_err_count_value = ref (fun () -> (0 [@coverage off]))
313	let log_warn_count_value = ref (fun () -> (0 [@coverage off]))
314	let error_count_value = ref 0
315	let warning_count_value = ref 0
316
317	let error_count () =
318	if am_running_test ()	94✔
319	then !error_count_value	76✔
320	else !error_count_value + log_err_count_value.contents ()	18✔
321	;;
322
323	let had_errors () = error_count () > 0	29✔
324
325	let warning_count () =
326	if am_running_test ()	23✔
327	then !warning_count_value	18✔
328	else !warning_count_value + log_warn_count_value.contents ()	5✔
329	;;
330
331	let no_style_printer pp = Stdlib.prerr_string (Format.asprintf "%a" Pp.to_fmt pp)	98✔
332	let include_separator = ref false
333
334	let reset_counts () =
335	error_count_value := 0;	76✔
336	warning_count_value := 0
337	;;
338
339	let reset_separator () = include_separator := false	76✔
340
341	let prerr_message (t : Stdune.User_message.t) =
342	let use_no_style_printer =	83✔
343	!am_running_test_value	74✔
344	\|\|
345	match !color_mode_value with
346	\| `Never -> true	1✔
347	\| `Always \| `Auto -> false	1✔
348	in
349	let () =
350	if !include_separator then Stdlib.prerr_newline () else include_separator := true	20✔
351	in
352	t.loc
353	\|> Option.iter (fun loc ->
354	(if use_no_style_printer then no_style_printer else Stdune.Ansi_color.prerr)	7✔
355	(Stdune.Loc.pp loc
356	\|> Pp.map_tags ~f:(fun (Loc : Stdune.Loc.tag) ->	30✔
357	Stdune.User_message.Print_config.default Loc)));	30✔
358	let message = { t with loc = None } in	83✔
359	if use_no_style_printer
360	then no_style_printer (Stdune.User_message.pp message)	75✔
361	else Stdune.User_message.prerr message	8✔
362	;;
363
364	let prerr ?(reset_separator = false) (t : t) =	3✔
365	if reset_separator then include_separator := false;	14✔
366	Option.iter prerr_message (to_stdune_user_message ~level:Error t)	17✔
367	;;
368
369	module Log_level = struct
370	type t =
371	\| Quiet
372	\| App
373	\| Error
374	\| Warning
375	\| Info
376	\| Debug
377
378	let sexp_of_t : t -> Sexplib0.Sexp.t = function
379	\| Quiet -> Atom "Quiet"	1✔
380	\| App -> Atom "App"	1✔
381	\| Error -> Atom "Error"	1✔
382	\| Warning -> Atom "Warning"	1✔
383	\| Info -> Atom "Info"	1✔
384	\| Debug -> Atom "Debug"	1✔
385	;;
386
387	let all = [ Quiet; App; Error; Warning; Info; Debug ]
388
389	let to_index = function
390	\| Quiet -> 0	18✔
391	\| App -> 1	13✔
392	\| Error -> 2	77✔
393	\| Warning -> 3	93✔
394	\| Info -> 4	31✔
395	\| Debug -> 5	32✔
396	;;
397
398	let compare l1 l2 = Int.compare (to_index l1) (to_index l2)	125✔
399	let equal l1 l2 = Int.equal (to_index l1) (to_index l2)	7✔
400
401	let of_level (level : Level.t) : t =
402	match level with	117✔
403	\| Error -> Error	62✔
404	\| Warning -> Warning	21✔
405	\| Info -> Info	17✔
406	\| Debug -> Debug	17✔
407	;;
408
409	let to_string = function
410	\| Quiet -> "quiet"	29✔
411	\| App -> "app"	29✔
412	\| Error -> "error"	29✔
413	\| Warning -> "warning"	29✔
414	\| Info -> "info"	29✔
415	\| Debug -> "debug"	29✔
416	;;
417	end
418
419	let warn_error_value = ref false
420
421	let log_level_get_value, log_level_set_value =
422	let value = ref Log_level.Warning in
423	ref (fun () -> (!value [@coverage off])), ref (fun v -> value := (v [@coverage off]))	115✔
424	;;
425
426	let log_level () = log_level_get_value.contents ()	117✔
427	let log_enables ~level = Log_level.compare (log_level ()) (Log_level.of_level level) >= 0	117✔
428
429	let error ?loc ?hints paragraphs =
430	incr error_count_value;	26✔
431	if log_enables ~level:Error	26✔
432	then (	21✔
433	let message = make_message ~level:Error ?loc ?hints paragraphs in
434	prerr_message message)	21✔
435	;;
436
437	let warning ?loc ?hints paragraphs =
438	incr warning_count_value;	19✔
439	if log_enables ~level:Warning	19✔
440	then (	13✔
441	let message = make_message ~level:Warning ?loc ?hints paragraphs in
442	prerr_message message)	13✔
443	;;
444
445	let info ?loc ?hints paragraphs =
446	if log_enables ~level:Info	15✔
447	then (	4✔
448	let message = make_message ~level:Info ?loc ?hints paragraphs in
449	prerr_message message)	4✔
450	;;
451
452	let debug ?loc ?hints paragraphs =
453	if log_enables ~level:Debug	15✔
454	then (	2✔
455	let message = make_message ~level:Debug ?loc ?hints (Lazy.force paragraphs) in	2✔
456	prerr_message message)	2✔
457	;;
458
459	let emit t ~level =
460	(match (level : Level.t) with	10✔
461	\| Error -> incr error_count_value	4✔
462	\| Warning -> incr warning_count_value	2✔
463	\| Info \| Debug -> ());	2✔
464	if log_enables ~level then Option.iter prerr_message (to_stdune_user_message t ~level)	7✔
465	;;
466
467	let pp_backtrace backtrace =
468	if am_running_test ()	4✔
469	then [ "<backtrace disabled in tests>" ]	3✔
470	else
471	String.split_on_char '\n' (Printexc.raw_backtrace_to_string backtrace)	1✔
472	\|> List.filter (fun s -> not (String.length s = 0))	1✔
473	;;
474
475	let handle_messages_and_exit ~err:({ exit_code; _ } as t) ~backtrace =
476	if log_enables ~level:Error	28✔
477	then (	24✔
478	Option.iter prerr_message (to_stdune_user_message ~level:Error t);	24✔
479	if Int.equal exit_code Exit_code.internal_error	24✔
480	then (	1✔
481	let message =
482	let prefix = Pp.seq (Pp_tty.tag Error (Pp.verbatim "Backtrace")) (Pp.char ':') in	1✔
483	let backtrace = pp_backtrace backtrace in	1✔
484	Stdune.User_message.make	1✔
485	~prefix
486	[ Pp.concat_map ~sep:(Pp.break ~nspaces:1 ~shift:0) backtrace ~f:Pp.verbatim ]	1✔
487	in
488	prerr_message message));	1✔
489	Error exit_code	28✔
490	;;
491
492	let had_errors_or_warn_errors () =
493	error_count () > 0 \|\| (!warn_error_value && warning_count () > 0)	2✔
494	;;
495
496	let protect ?(exn_handler = Fun.const None) f =	73✔
497	reset_counts ();	76✔
498	reset_separator ();	76✔
499	match f () with	76✔
500	\| ok -> if had_errors_or_warn_errors () then Error Exit_code.some_error else Ok ok	16✔
501	\| exception E err ->	26✔
502	let backtrace = Printexc.get_raw_backtrace () in
503	handle_messages_and_exit ~err ~backtrace	26✔
504	\| exception exn ->	6✔
505	let backtrace = Printexc.get_raw_backtrace () in
506	(match exn_handler exn with	6✔
507	\| Some err -> handle_messages_and_exit ~err ~backtrace	2✔
508	\| None ->	4✔
509	if log_enables ~level:Error
510	then (	3✔
511	let message =
512	let prefix =
513	Pp.seq (Pp_tty.tag Error (Pp.verbatim "Internal Error")) (Pp.char ':')	3✔
514	in
515	let backtrace = pp_backtrace backtrace in	3✔
516	Stdune.User_message.make	3✔
517	~prefix
518	[ Pp.concat_map	3✔
519	~sep:(Pp.break ~nspaces:1 ~shift:0)
520	(Printexc.to_string exn :: backtrace)	3✔
521	~f:Pp.verbatim
522	]
523	in
524	prerr_message message);	3✔
525	Error Exit_code.internal_error)	4✔
526	;;
527
528	module For_test = struct
529	let wrap f =
530	let init = am_running_test () in	72✔
531	am_running_test_value := true;	72✔
532	let init_level = log_level_get_value.contents () in
533	log_level_set_value.contents Log_level.Warning;	72✔
534	Fun.protect	72✔
535	~finally:(fun () ->
536	am_running_test_value := init;	72✔
537	log_level_set_value.contents init_level)
538	f
539	;;
540
541	let protect ?exn_handler f =
542	match wrap (fun () -> protect f ?exn_handler) with	56✔
543	\| Ok () -> ()	10✔
544	\| Error code -> if code <> 0 then Stdlib.prerr_endline (Printf.sprintf "[%d]" code)	44✔
545	;;
546	end
547
548	module Private = struct
549	let am_running_test = am_running_test_value
550
551	let reset_counts () =
552	error_count_value := 0;	4✔
553	warning_count_value := 0
554	;;
555
556	let reset_separator () = include_separator := false	1✔
557	let color_mode = color_mode_value
558
559	let set_log_level ~get ~set =
560	log_level_get_value := get;	42✔
561	log_level_set_value := set;
562	()
563	;;
564
565	let warn_error = warn_error_value
566
567	let set_log_counts ~err_count ~warn_count =
568	log_err_count_value := err_count;	41✔
569	log_warn_count_value := warn_count;
570	()
571	;;
572	end
573
574	let create_s ?loc ?hints ?exit_code desc s =
575	create ?loc ?hints ?exit_code [ Pp.text desc; sexp s ] [@coverage off]
576	;;
577
578	let raise_s ?loc ?hints ?exit_code desc s =
579	raise ?loc ?hints ?exit_code [ Pp.text desc; sexp s ] [@coverage off]
580	;;
581
582	let reraise_s bt e ?loc:_ ?hints:_ ?exit_code:_ desc s =
583	reraise_with_context e bt [ Pp.text desc; sexp s ] [@coverage off]
584	;;
585
586	let pp_of_sexp = sexp

mbarbin / pplumbing / 46

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