panic.ml 1.9 KB
Newer Older
Michael Sammler's avatar
Michael Sammler committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
(** Output and debugging utilities. *)

open Extra

type loc = Location_ocaml.t

let pp_loc : loc pp = fun oc loc ->
  Format.pp_print_string oc (Location_ocaml.location_to_string loc)

let pp_loc_opt : loc option pp = fun oc lopt ->
  Option.iter (Format.fprintf oc "[%a] " pp_loc) lopt

(** Short name for a standard formatter. *)
type 'a outfmt = ('a, Format.formatter, unit) format

(** Short name for a standard formatter with continuation. *)
type ('a, 'b) koutfmt = ('a, Format.formatter, unit, unit, unit, 'b) format6

(** Format transformers (colors). *)
let with_color k fmt = "\027[" ^^ k ^^ "m" ^^ fmt ^^ "\027[0m%!"

let red fmt = with_color "31" fmt
let gre fmt = with_color "32" fmt
let yel fmt = with_color "33" fmt
let blu fmt = with_color "34" fmt
let mag fmt = with_color "35" fmt
let cya fmt = with_color "36" fmt

(** [wrn loc_opt fmt] outputs a waning to [stderr] using [Format] format [fmt]
    and the correponding arguments. If [loc_opt] is [Some(loc)], then location
    [loc] is shown as a prefix of the warning. Note that a newline is added to
    the end of the message automatically, and that [stderr] is flushed. *)
let wrn : loc option -> 'a outfmt -> 'a = fun lopt fmt ->
  Format.eprintf (yel ("%a" ^^ fmt ^^ "\n")) pp_loc_opt lopt

(** [panic loc fmt] interrupts the program with [exit 1], after displaying the
    error message described by [Format] format [fmt].  Location [loc] is shown
    as a prefix of the error message,  and a newline is automatically inserted
    at its end ([stderr] is also flushed) *)
let panic : loc -> ('a, 'b) koutfmt -> 'a = fun loc fmt ->
  let fmt = red ("[%a] " ^^ fmt ^^ "\n") in
  Format.kfprintf (fun _ -> exit 1) Format.err_formatter fmt pp_loc loc

(** [panic_no_pos fmt] is similar to [panic _ fmt], but has no location. *)
let panic_no_pos : ('a,'b) koutfmt -> 'a = fun fmt ->
  let fmt = red (fmt ^^ "\n") in
  Format.kfprintf (fun _ -> exit 1) Format.err_formatter fmt