Source file console.ml

module type Backend = Backend_intf.S

let sprintf = Printf.sprintf

module Backend = struct
  type t = Backend_intf.t

  let dumb = (module Dumb : Backend_intf.S)
  let progress = Progress.flush
  let compose = Combinators.compose
  let main = ref dumb

  let set (module T : Backend_intf.S) =
    let module Old = (val !main) in
    Old.finish ();
    main := (module T);
    T.start ()
  ;;

  let flush t = Combinators.flush t
  let progress_no_flush = Progress.no_flush
end

(* Flag that controls whether messages should be separated by a blank line *)
let separate_messages_flag = ref false

(* A user message that solely contains a blank line *)
let blank_line_msg =
  { User_message.paragraphs = [ Pp.cut ]
  ; hints = []
  ; compound = []
  ; loc = None
  ; context = None
  ; dir = None
  ; has_embedded_location = false
  ; needs_stack_trace = false
  ; promotion = None
  }
;;

(** Prints a blank line *)
let print_blank_line () =
  let (module M : Backend_intf.S) = !Backend.main in
  M.print_user_message blank_line_msg
;;

let first_msg = ref true
let separate_messages v = separate_messages_flag := v

type directory_state =
  | Not_set
  | Set of string
  | Entering_printed of string

let directory = ref Not_set

let set_directory dir =
  match !directory with
  | Not_set -> directory := Set dir
  | Set _ | Entering_printed _ -> ()
;;

(* If the [separate_messages = false], then [print_blank_line ()] does nothing.
   When [separate_messages = true], [print_blank_line ()] does nothing the
   first time it is called, whereas subsequent calls print a new line. Note
   that calls to [reset] or [reset_flush_history] will erase the information
   of whether some message has already been printed. As a consequence, after a
   call to [reset] or [reset_flush_history], [print_blank_line] will behave as
   if it has never been called before. *)
let print_blank_line () =
  if !separate_messages_flag
  then
    (* only do something when the flag is on, i.e. the first time
       the function is called *)
    if !first_msg
    then
      (* do not print anything the first time the function is
         called, but remember it has been called at least once *)
      first_msg := false
    else
      (* if the function has already been called at least once,
         print a blank line *)
      print_blank_line ()
;;

let print_user_message msg =
  let (module M : Backend_intf.S) = !Backend.main in
  (match !directory with
   | Set dir ->
     flush stdout;
     directory := Entering_printed dir;
     M.print_user_message
       (User_message.make [ Pp.verbatim (Printf.sprintf "Entering directory '%s'" dir) ])
   | Not_set | Entering_printed _ -> ());
  print_blank_line ();
  M.print_user_message msg
;;

let print paragraphs = print_user_message (User_message.make paragraphs)
let printf fmt = Printf.ksprintf (fun msg -> print [ Pp.verbatim msg ]) fmt

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

let print_if_no_status_line line =
  let (module M : Backend_intf.S) = !Backend.main in
  M.print_if_no_status_line line
;;

let reset () =
  (* forget that [print_user_message] has ever been called *)
  first_msg := true;
  let (module M : Backend_intf.S) = !Backend.main in
  M.reset ()
;;

let reset_flush_history () =
  (* forget that [print_user_message] has ever been called *)
  first_msg := true;
  let (module M : Backend_intf.S) = !Backend.main in
  M.reset_flush_history ()
;;

let finish () =
  let (module M : Backend_intf.S) = !Backend.main in
  (match !directory with
   | Entering_printed dir ->
     directory := Set dir;
     M.print_user_message
       (User_message.make [ Pp.verbatim (Printf.sprintf "Leaving directory '%s'" dir) ])
   | Not_set | Set _ -> ());
  M.finish ()
;;

let () = at_exit finish

module Status_line = struct
  type t =
    | Live of (unit -> User_message.Style.t Pp.t)
    | Constant of User_message.Style.t Pp.t

  module Id = Id.Make ()

  let toplevel = Id.gen ()
  let stack = ref []
  let sections = ref []

  let pp_if_not_nop t =
    let pp =
      match t with
      | Live f -> f ()
      | Constant x -> x
    in
    match Pp.to_ast pp with
    | Nop -> []
    | _ -> [ pp ]
  ;;

  let refresh () =
    let pps =
      let section_pps =
        List.rev !sections |> List.concat_map ~f:(fun (_id, t) -> pp_if_not_nop t)
      in
      match !stack with
      | [] -> section_pps
      | (_id, t) :: _ -> pp_if_not_nop t @ section_pps
    in
    match pps with
    | [] -> set_status_line None
    | _ :: _ ->
      let pp = Pp.concat pps ~sep:(Pp.verbatim " | ") in
      (* Always put the status line inside a horizontal box to force the
         [Format] module to prefer a single line. In particular, it seems that
         [Format.pp_print_text] split the 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 t =
    stack := [ toplevel, t ];
    (match t with
     | Live _ -> ()
     | Constant pp -> print_if_no_status_line pp);
    refresh ()
  ;;

  let clear () =
    stack := [];
    refresh ()
  ;;

  type overlay = Id.t

  let add_overlay t =
    let id = Id.gen () in
    stack := (id, t) :: !stack;
    refresh ();
    id
  ;;

  let remove_overlay id =
    stack := List.filter !stack ~f:(fun (id', _) -> not (Id.equal id id'));
    refresh ()
  ;;

  let with_overlay t ~f =
    let id = add_overlay t in
    Exn.protect ~f ~finally:(fun () -> remove_overlay id)
  ;;

  type section = Id.t

  let add_section t =
    let id = Id.gen () in
    sections := (id, t) :: !sections;
    refresh ();
    id
  ;;

  let remove_section id =
    sections := List.filter !sections ~f:(fun (id', _) -> not (Id.equal id id'));
    refresh ()
  ;;
end

let () = User_warning.set_reporter print_user_message

let () =
  Log.set_forward_verbose (fun msg args ->
    let formatted_args =
      List.map args ~f:(fun (k, v) -> Printf.sprintf "%s: %s" k (Dyn.to_string v))
      |> String.concat ~sep:" "
    in
    let full_msg =
      if String.is_empty formatted_args
      then msg
      else Printf.sprintf "%s %s" msg formatted_args
    in
    print [ Pp.verbatim full_msg ])
;;

let terminal_persistence = ref Terminal_persistence.Preserve

let init (terminal_persistence' : Terminal_persistence.t) =
  terminal_persistence := terminal_persistence';
  match !terminal_persistence with
  | Preserve -> ()
  | Clear_on_rebuild -> reset ()
  | Clear_on_rebuild_and_flush_history -> reset_flush_history ()
;;

let maybe_clear_screen ~details_hum =
  match Execution_env.inside_dune with
  | true -> (* Don't print anything here to make tests less verbose *) ()
  | false ->
    (match !terminal_persistence with
     | Clear_on_rebuild -> reset ()
     | Clear_on_rebuild_and_flush_history -> reset_flush_history ()
     | Preserve ->
       let message =
         sprintf
           "********** NEW BUILD (%s) **********"
           (String.concat ~sep:", " details_hum)
       in
       print_user_message
         (User_message.make
            [ Pp.nop; Pp.tag User_message.Style.Success (Pp.verbatim message); Pp.nop ]))
;;