Source file console.ml

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
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
module Backend = struct
  module type S = sig
    val print_user_message : User_message.t -> unit

    val set_status_line : User_message.Style.t Pp.t option -> unit

    val reset : unit -> unit
  end

  type t = (module S)

  module Dumb_no_flush : S = struct
    let print_user_message msg =
      Option.iter msg.User_message.loc ~f:(fun loc ->
          Loc.render Format.err_formatter (Loc.pp loc));
      User_message.prerr { msg with loc = None }

    let set_status_line _ = ()

    let reset () = prerr_string "\x1bc"
  end

  module Dumb : S = struct
    include Dumb_no_flush

    let print_user_message msg =
      print_user_message msg;
      flush stderr

    let reset () =
      reset ();
      flush stderr
  end

  module Progress : S = struct
    let status_line = ref Pp.nop

    let status_line_len = ref 0

    let hide_status_line () =
      if !status_line_len > 0 then Printf.eprintf "\r%*s\r" !status_line_len ""

    let show_status_line () =
      if !status_line_len > 0 then Ansi_color.prerr !status_line

    let set_status_line = function
      | None ->
        hide_status_line ();
        status_line := Pp.nop;
        status_line_len := 0;
        flush stderr
      | Some line ->
        let line = Pp.map_tags line ~f:User_message.Print_config.default in
        let line_len =
          String.length (Format.asprintf "%a" Pp.render_ignore_tags line)
        in
        hide_status_line ();
        status_line := line;
        status_line_len := line_len;
        show_status_line ();
        flush stderr

    let print_user_message msg =
      hide_status_line ();
      Dumb_no_flush.print_user_message msg;
      show_status_line ();
      flush stderr

    let reset () = Dumb.reset ()
  end

  let dumb = (module Dumb : S)

  let progress = (module Progress : S)

  let main = ref dumb

  let set t = main := t

  let compose (module A : S) (module B : S) =
    ( module struct
      let print_user_message msg =
        A.print_user_message msg;
        B.print_user_message msg

      let set_status_line x =
        A.set_status_line x;
        B.set_status_line x

      let reset () =
        A.reset ();
        B.reset ()
    end : S )
end

let print_user_message msg =
  let (module M : Backend.S) = !Backend.main in
  M.print_user_message msg

let print paragraphs = print_user_message (User_message.make paragraphs)

let set_status_line line =
  let (module M : Backend.S) = !Backend.main in
  M.set_status_line line

let reset () =
  let (module M : Backend.S) = !Backend.main in
  M.reset ()

module Status_line = struct
  type t = unit -> User_message.Style.t Pp.t option

  let status_line = ref (Fun.const None)

  let refresh () =
    match !status_line () with
    | None -> set_status_line None
    | Some pp ->
      (* Always put the status line inside a horizontal to force the [Format]
         module to prefer a single line. In particular, it seems that
         [Format.pp_print_text] split sthe line before the last word, unless it
         is succeeded by a space. This seems like a bug in [Format] and putting
         the whole thing into a [hbox] works around this bug.

         See https://github.com/ocaml/dune/issues/2779 *)
      set_status_line (Some (Pp.hbox pp))

  let set x =
    status_line := x;
    refresh ()

  let set_temporarily x f =
    let old = !status_line in
    set x;
    Exn.protect ~finally:(fun () -> set old) ~f
end

let () = User_warning.set_reporter print_user_message