feature: add terminal ui backend based on NoTTY (#6996)

Signed-off-by: Ali Caglayan <alizter@gmail.com>

bin/install_uninstall.ml

@@ -668,7 +668,11 @@ let install_uninstall ~what =
                 [ Pp.text "Option --prefix is needed with --relocation" ]
           else None
         in
-        let verbosity = config.display.verbosity in
+        let verbosity =
+          match config.display with
+          | Simple display -> display.verbosity
+          | Tui -> Quiet
+        in
         let open Fiber.O in
         let (module Ops) = file_operations ~verbosity ~dry_run ~workspace in
         let files_deleted_in = ref Path.Set.empty in

bin/target.ml

@@ -217,7 +217,8 @@ let resolve_targets root (config : Dune_config.t)
     let+ targets =
       Action_builder.List.map user_targets ~f:(resolve_target root ~setup)
     in
-    if config.display.verbosity = Verbose then
+    (match config.display with
+    | Simple { verbosity = Verbose; _ } ->
       Log.info
         [ Pp.text "Actual targets:"
         ; Pp.enumerate
@@ -227,7 +228,8 @@ let resolve_targets root (config : Dune_config.t)
             ~f:(function
               | File p -> Pp.verbatim (Path.to_string_maybe_quoted p)
               | Alias a -> Alias.pp a)
-        ];
+        ]
+    | _ -> ());
     targets
 
 let resolve_targets_exn root config setup user_targets =

boot/libs.ml

@@ -52,6 +52,10 @@ let local_libraries =
   ; ("src/dune_file_watcher", Some "Dune_file_watcher", false, None)
   ; ("src/dune_engine", Some "Dune_engine", false, None)
   ; ("src/dune_threaded_console", Some "Dune_threaded_console", false, None)
+  ; ("vendor/uutf", None, false, None)
+  ; ("vendor/notty/src", None, true, None)
+  ; ("vendor/notty/src-unix", None, true, None)
+  ; ("src/dune_tui", Some "Dune_tui", false, None)
   ; ("src/dune_config", Some "Dune_config", false, None)
   ; ("src/dune_rules", Some "Dune_rules", true, None)
   ; ("src/upgrader", Some "Dune_upgrader", false, None)

src/dune_config/display.ml

@@ -1,37 +1,47 @@
 module Display = Dune_engine.Display
 
 type t =
-  { status_line : bool
-  ; verbosity : Display.t
-  }
+  | Simple of
+      { status_line : bool
+      ; verbosity : Display.t
+      }
+  | Tui
 
-let progress = { status_line = true; verbosity = Quiet }
+let progress = Simple { status_line = true; verbosity = Quiet }
 
-let verbose = { status_line = true; verbosity = Verbose }
+let verbose = Simple { status_line = true; verbosity = Verbose }
 
-let short = { status_line = true; verbosity = Short }
+let short = Simple { status_line = true; verbosity = Short }
 
-let quiet = { status_line = false; verbosity = Quiet }
+let quiet = Simple { status_line = false; verbosity = Quiet }
 
-let short_no_status = { status_line = false; verbosity = Short }
+let short_no_status = Simple { status_line = false; verbosity = Short }
 
 (* Even though [status_line] is true by default in most of these, the status
-    line is actually not shown if the output is redirected to a file or a
-    pipe. *)
+   line is actually not shown if the output is redirected to a file or a
+   pipe. *)
 let all =
   [ ("progress", progress)
   ; ("verbose", verbose)
   ; ("short", short)
   ; ("quiet", quiet)
+  ; ("tui", Tui)
   ]
 
-let to_dyn { status_line; verbosity } : Dyn.t =
-  Record
-    [ ("status_line", Dyn.Bool status_line)
-    ; ("verbosity", Display.to_dyn verbosity)
-    ]
-
-let console_backend t =
-  match t.status_line with
-  | false -> Dune_console.Backend.dumb
-  | true -> Dune_threaded_console.progress ()
+let to_dyn : t -> Dyn.t = function
+  | Simple { verbosity; status_line } ->
+    Variant
+      ( "Simple"
+      , [ Record
+            [ ("verbosity", Display.to_dyn verbosity)
+            ; ("status_line", Dyn.Bool status_line)
+            ]
+        ] )
+  | Tui -> Variant ("Tui", [])
+
+let console_backend = function
+  | Tui -> Dune_tui.backend ()
+  | Simple { status_line; _ } -> (
+    match status_line with
+    | false -> Dune_console.Backend.dumb
+    | true -> Dune_console.Backend.progress)

src/dune_config/display.mli

@@ -3,9 +3,11 @@
     - [status_line] indictates if a status line is shown.
     - [verbosity] indicates how verbose the display will be. *)
 type t =
-  { status_line : bool
-  ; verbosity : Dune_engine.Display.t
-  }
+  | Simple of
+      { status_line : bool
+      ; verbosity : Dune_engine.Display.t
+      }
+  | Tui
 
 (** All the supported display modes for setting from the command line. *)
 val all : (string * t) list

src/dune_config/dune

@@ -11,6 +11,7 @@
   dune_engine
   dune_rpc_private
   dune_stats
+  dune_tui
   dune_util
   spawn)
  (synopsis "Internal Dune library, do not use!")

src/dune_config/dune_config.ml

@@ -262,7 +262,7 @@ let hash = Poly.hash
 let equal a b = Poly.equal a b
 
 let default =
-  { display = { verbosity = Quiet; status_line = not Config.inside_dune }
+  { display = Simple { verbosity = Quiet; status_line = not Config.inside_dune }
   ; concurrency = (if Config.inside_dune then Fixed 1 else Auto)
   ; terminal_persistence = Clear_on_rebuild
   ; sandboxing_preference = []
@@ -370,11 +370,11 @@ let adapt_display config ~output_is_a_tty =
   (* Progress isn't meaningful if inside a terminal (or emacs), so disable it if
      the output is getting piped to a file or something. *)
   let config =
-    if
-      config.display.status_line && (not output_is_a_tty)
-      && not Config.inside_emacs
-    then { config with display = { config.display with status_line = false } }
-    else config
+    match config.display with
+    | Simple { verbosity; _ }
+      when (not output_is_a_tty) && not Config.inside_emacs ->
+      { config with display = Simple { verbosity; status_line = false } }
+    | _ -> config
   in
   (* Similarly, terminal clearing is meaningless if stderr doesn't support ANSI
      codes, so revert-back to Preserve in that case *)
@@ -389,7 +389,10 @@ let init t ~watch =
    | Preserve -> ()
    | Clear_on_rebuild -> Console.reset ()
    | Clear_on_rebuild_and_flush_history -> Console.reset_flush_history ());
-  Log.verbose := t.display.verbosity = Verbose
+  Log.verbose :=
+    match t.display with
+    | Simple { verbosity = Verbose; _ } -> true
+    | _ -> false
 
 let auto_concurrency =
   lazy
@@ -447,5 +450,8 @@ let for_scheduler (t : t) stats ~insignificant_changes ~signal_watcher =
       Log.info [ Pp.textf "Auto-detected concurrency: %d" n ];
       n
   in
-  Dune_engine.Clflags.display := t.display.verbosity;
+  (Dune_engine.Clflags.display :=
+     match t.display with
+     | Tui -> Dune_engine.Display.Quiet
+     | Simple { verbosity; _ } -> verbosity);
   { Scheduler.Config.concurrency; stats; insignificant_changes; signal_watcher }

src/dune_threaded_console/dune_threaded_console_intf.ml

@@ -35,10 +35,10 @@ module type S = sig
       things like waiting for user input.
 
       [time_budget] should be as accurate as possible, but if it's not, the only
-      consequence would be modifying the rendering rate. That is, if
-      [time_budget] is an underestimate the actual amount of time spent, we will
-      render faster than the desired frame rate. If it is an overestimate, we
-      will render slower. *)
+      consequence would be modifying the rendering rate. If [time_budget] is an
+      underestimation of the actual amount of time spent, we will render faster
+      than the desired frame rate. If it is an overestimation, we will render
+      slower. *)
   val handle_user_events : now:float -> time_budget:float -> Mutex.t -> float
 
   (** [reset] is called by the main thread to reset the user interface. *)

src/dune_tui/dune

@@ -0,0 +1,11 @@
+(library
+ (name dune_tui)
+ (libraries
+  stdune
+  dune_notty
+  dune_notty_unix
+  dune_console
+  dune_threaded_console
+  threads.posix)
+ (instrumentation
+  (backend bisect_ppx)))

src/dune_tui/dune_tui.ml

@@ -0,0 +1,131 @@
+open Stdune
+
+let attr_of_ansi_color_style (s : Ansi_color.Style.t) =
+  let module A = Notty.A in
+  match s with
+  | `Fg_black -> A.(fg black)
+  | `Fg_red -> A.(fg red)
+  | `Fg_green -> A.(fg green)
+  | `Fg_yellow -> A.(fg yellow)
+  | `Fg_blue -> A.(fg blue)
+  | `Fg_magenta -> A.(fg magenta)
+  | `Fg_cyan -> A.(fg cyan)
+  | `Fg_white -> A.(fg white)
+  | `Fg_default -> A.empty
+  | `Fg_bright_black -> A.(fg lightblack)
+  | `Fg_bright_red -> A.(fg lightred)
+  | `Fg_bright_green -> A.(fg lightgreen)
+  | `Fg_bright_yellow -> A.(fg lightyellow)
+  | `Fg_bright_blue -> A.(fg lightblue)
+  | `Fg_bright_magenta -> A.(fg lightmagenta)
+  | `Fg_bright_cyan -> A.(fg lightcyan)
+  | `Fg_bright_white -> A.(fg lightwhite)
+  | `Bg_black -> A.(bg black)
+  | `Bg_red -> A.(bg red)
+  | `Bg_green -> A.(bg green)
+  | `Bg_yellow -> A.(bg yellow)
+  | `Bg_blue -> A.(bg blue)
+  | `Bg_magenta -> A.(bg magenta)
+  | `Bg_cyan -> A.(bg cyan)
+  | `Bg_white -> A.(bg white)
+  | `Bg_default -> A.empty
+  | `Bg_bright_black -> A.(bg lightblack)
+  | `Bg_bright_red -> A.(bg lightred)
+  | `Bg_bright_green -> A.(bg lightgreen)
+  | `Bg_bright_yellow -> A.(bg lightyellow)
+  | `Bg_bright_blue -> A.(bg lightblue)
+  | `Bg_bright_magenta -> A.(bg lightmagenta)
+  | `Bg_bright_cyan -> A.(bg lightcyan)
+  | `Bg_bright_white -> A.(bg lightwhite)
+  | `Bold -> A.(st bold)
+  | `Italic -> A.(st italic)
+  | `Dim -> A.(st dim)
+  | `Underline -> A.(st underline)
+
+let attr_of_user_message_style fmt t (pp : User_message.Style.t Pp.t) : unit =
+  let attr =
+    let module A = Notty.A in
+    match (t : User_message.Style.t) with
+    | Loc -> A.(st bold)
+    | Error -> A.(st bold ++ fg red)
+    | Warning -> A.(st bold ++ fg magenta)
+    | Kwd -> A.(st bold ++ fg blue)
+    | Id -> A.(st bold ++ fg yellow)
+    | Prompt -> A.(st bold ++ fg green)
+    | Hint -> A.(st italic ++ fg white)
+    | Details -> A.(st dim ++ fg white)
+    | Ok -> A.(st italic ++ fg green)
+    | Debug -> A.(st underline ++ fg lightcyan)
+    | Success -> A.(st bold ++ fg green)
+    | Ansi_styles l ->
+      List.fold_left ~init:A.empty l ~f:(fun attr s ->
+          A.(attr ++ attr_of_ansi_color_style s))
+  in
+  Notty.I.pp_attr attr Pp.to_fmt fmt pp
+
+let image_of_user_message_style_pp =
+  Notty.I.strf "%a@."
+    (Pp.to_fmt_with_tags ~tag_handler:attr_of_user_message_style)
+
+module Tui () = struct
+  module Term = Notty_unix.Term
+
+  let term = Term.create ~nosig:false ()
+
+  let start () = Unix.set_nonblock Unix.stdin
+
+  let image ~status_line ~messages =
+    let status =
+      match (status_line : User_message.Style.t Pp.t option) with
+      | None -> []
+      | Some message -> [ image_of_user_message_style_pp message ]
+    in
+    let messages =
+      List.map messages ~f:(fun msg ->
+          image_of_user_message_style_pp (User_message.pp msg))
+    in
+    Notty.I.vcat (messages @ status)
+
+  let render (state : Dune_threaded_console.state) =
+    let messages = Queue.to_list state.messages in
+    let image = image ~status_line:state.status_line ~messages in
+    Term.image term image
+
+  let rec handle_user_events ~now ~time_budget _mutex =
+    (* We check for any user input and handle it. If we go over the
+       [time_budget] we give up and continue. *)
+    let input_fds, _, _ = Unix.select [ Unix.stdin ] [] [] time_budget in
+    match input_fds with
+    | [] ->
+      now +. time_budget
+      (* Nothing to do, we return the time at the end of the time budget. *)
+    | _ :: _ -> (
+      (* TODO if anything fancy is done in the UI in the future we need to lock
+         the state with the provided mutex *)
+      match Term.event term with
+      | `Key (`ASCII 'q', _) ->
+        (* When we encounter q we make sure to quit by signaling termination. *)
+        Unix.kill (Unix.getpid ()) Sys.sigterm;
+        Unix.gettimeofday ()
+      | _ -> Unix.gettimeofday ()
+      | exception Unix.Unix_error ((EAGAIN | EWOULDBLOCK), _, _) ->
+        (* If we encounter an exception, we make sure to rehandle user events
+           with a corrected time budget. *)
+        let old_now = now in
+        let now = Unix.gettimeofday () in
+        let delta_now = now -. old_now in
+        let time_budget = Float.max 0. (time_budget -. delta_now) in
+        handle_user_events ~now ~time_budget _mutex)
+
+  let reset () = ()
+
+  let reset_flush_history () = ()
+
+  let finish () =
+    Notty_unix.Term.release term;
+    Unix.clear_nonblock Unix.stdin
+end
+
+let backend =
+  let t = lazy (Dune_threaded_console.make (module Tui ())) in
+  fun () -> Lazy.force t

src/dune_tui/dune_tui.mli

@@ -0,0 +1,2 @@
+(** A backend that uses Notty to display the status line in the terminal. *)
+val backend : unit -> Dune_console.Backend.t

test/expect-tests/dune_config/dune_config_test.ml

@@ -20,7 +20,7 @@ let%expect_test "cache-check-probability 0.1" =
   parse "(cache-check-probability 0.1)";
   [%expect
     {|
-    { display = { status_line = false; verbosity = Quiet }
+    { display = Simple { verbosity = Quiet; status_line = false }
     ; concurrency = Fixed 1
     ; terminal_persistence = Clear_on_rebuild
     ; sandboxing_preference = []
@@ -36,7 +36,7 @@ let%expect_test "cache-storage-mode copy" =
   parse "(cache-storage-mode copy)";
   [%expect
     {|
-    { display = { status_line = false; verbosity = Quiet }
+    { display = Simple { verbosity = Quiet; status_line = false }
     ; concurrency = Fixed 1
     ; terminal_persistence = Clear_on_rebuild
     ; sandboxing_preference = []
@@ -52,7 +52,7 @@ let%expect_test "cache-storage-mode hardlink" =
   parse "(cache-storage-mode hardlink)";
   [%expect
     {|
-    { display = { status_line = false; verbosity = Quiet }
+    { display = Simple { verbosity = Quiet; status_line = false }
     ; concurrency = Fixed 1
     ; terminal_persistence = Clear_on_rebuild
     ; sandboxing_preference = []

vendor/notty/LICENSE.md

@@ -0,0 +1,13 @@
+Copyright (c) 2016-2017 David Kaloper Meršinjak
+
+Permission to use, copy, modify, and/or distribute this software for any
+purpose with or without fee is hereby granted, provided that the above
+copyright notice and this permission notice appear in all copies.
+
+THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

vendor/notty/src-unix/dune

@@ -0,0 +1,10 @@
+(library
+  (synopsis "Notty Unix IO")
+  (name dune_notty_unix)
+  (wrapped false)
+  (foreign_stubs
+    (language c)
+    (names winsize))
+  (libraries dune_notty unix))
+
+(include_subdirs unqualified)