tui: add more features

We add more features to Dune's TUI. Using Lwd and Nottui we expand on
the Notty TUI by creating an interactive UI for dune_console.

- The user can now view all the messages and scroll in the console.
- Each message can be minimized or expanded by clicking.
- There is a help screen showing which buttons can be pressed.
- The build status is printed in a status bar at the top.
- And more.

Signed-off-by: Ali Caglayan <[email protected]>

boot/libs.ml

@@ -74,9 +74,11 @@ let local_libraries =
     None)
   ; ("src/dune_vcs", Some "Dune_vcs", false, None)
   ; ("src/dune_threaded_console", Some "Dune_threaded_console", false, None)
+  ; ("vendor/lwd/lwd", None, false, None)
   ; ("vendor/notty/src", None, true, None)
   ; ("vendor/notty/src-unix", None, true, None)
-  ; ("src/dune_tui", Some "Dune_tui", false, None)
+  ; ("vendor/lwd/nottui", None, false, None)
+  ; ("src/dune_tui", Some "Dune_tui", true, None)
   ; ("src/dune_config_file", Some "Dune_config_file", false, None)
   ; ("src/dune_shared_cache", Some "Dune_shared_cache", false, None)
   ; ("src/scheme", Some "Scheme", false, None)

src/dune_tui/drawing/box.ml

@@ -0,0 +1,35 @@
+open Import
+
+let border_box ~attr image =
+  let w, h = I.(width image, height image) in
+  let border_element ?(width = 1) ?(height = 1) unicode valign halign =
+    I.uchar attr (Uchar.of_int unicode) width height
+    |> I.vsnap ~align:valign (h + 2)
+    |> I.hsnap ~align:halign (w + 2)
+  in
+  I.zcat
+    [ border_element 0x2554 `Top `Left (* top left corner *)
+    ; border_element 0x2557 `Top `Right (* top right corner *)
+    ; border_element 0x255A `Bottom `Left (* bottom left corner *)
+    ; border_element 0x255D `Bottom `Right (* bottom right corner *)
+    ; border_element ~width:w 0x2550 `Top `Middle (* top border *)
+    ; border_element ~width:w 0x2550 `Bottom `Middle (* bottom border *)
+    ; border_element ~height:h 0x2551 `Middle `Left (* left border *)
+    ; border_element ~height:h 0x2551 `Middle `Right (* right border *)
+    ; I.pad ~l:1 ~t:1 ~r:1 ~b:1 image
+    ; I.char A.empty ' ' (w + 2) (h + 2)
+    ]
+;;
+
+let with_title ~attr ~title ~title_attr image =
+  let title =
+    [ I.uchar attr (Uchar.of_int 0x2561) 1 1
+    ; I.string title_attr (" " ^ title ^ " ")
+    ; I.uchar attr (Uchar.of_int 0x255E) 1 1
+    ]
+    |> I.hcat
+    |> I.hsnap ~align:`Middle (I.width image + 2)
+    |> I.vsnap ~align:`Top (I.height image + 2)
+  in
+  I.(title </> border_box ~attr image)
+;;

src/dune_tui/drawing/box.mli

@@ -0,0 +1,10 @@
+open Import
+
+(** [Notty.image] utilities for drawing boxes. *)
+
+(** [with_title ~attr ~title ~title_attr img] draws a bordered box around the [img] which
+    has [attr] as a style. It also has a [title] at the top with [title_attr].
+
+    The box is drawn straight over the top of the image, so make sure to [I.pad] the
+    outside. *)
+val with_title : attr:A.t -> title:string -> title_attr:A.t -> I.t -> I.t

src/dune_tui/drawing/user_message_to_image.ml

@@ -0,0 +1,111 @@
+open Stdune
+
+let attr_of_ansi_color_rgb8 (c : Ansi_color.RGB8.t) =
+  let module A = Notty.A in
+  match Ansi_color.RGB8.to_int c with
+  | 0 -> A.black
+  | 1 -> A.red
+  | 2 -> A.green
+  | 3 -> A.yellow
+  | 4 -> A.blue
+  | 5 -> A.magenta
+  | 6 -> A.cyan
+  | 7 -> A.white
+  | 8 -> A.lightblack
+  | 9 -> A.lightred
+  | 10 -> A.lightgreen
+  | 11 -> A.lightyellow
+  | 12 -> A.lightblue
+  | 13 -> A.lightmagenta
+  | 14 -> A.lightcyan
+  | 15 -> A.lightwhite
+  | i when i <= 231 ->
+    let i = i - 16 in
+    let r = i / 36 in
+    let g = i / 6 mod 6 in
+    let b = i mod 6 in
+    A.rgb ~r ~g ~b
+  | i when i <= 255 -> A.gray (i - 232)
+  | i -> Code_error.raise "invalid 8-bit color" [ "value", Dyn.int i ]
+;;
+
+let attr_of_ansi_color_rgb24 (c : Ansi_color.RGB24.t) =
+  let module A = Notty.A in
+  A.rgb
+    ~r:(Ansi_color.RGB24.red c)
+    ~g:(Ansi_color.RGB24.green c)
+    ~b:(Ansi_color.RGB24.blue c)
+;;
+
+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)
+  | `Fg_8_bit_color c -> A.fg (attr_of_ansi_color_rgb8 c)
+  | `Fg_24_bit_color c -> A.fg (attr_of_ansi_color_rgb24 c)
+  | `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)
+  | `Bg_8_bit_color c -> A.bg (attr_of_ansi_color_rgb8 c)
+  | `Bg_24_bit_color c -> A.bg (attr_of_ansi_color_rgb24 c)
+  | `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 pp ?attr =
+  Notty.I.strf ?attr "%a" (Pp.to_fmt_with_tags ~tag_handler:attr_of_user_message_style)
+;;

src/dune_tui/drawing/user_message_to_image.mli

@@ -0,0 +1,5 @@
+open Stdune
+
+(** [User_message_to_image.pp ~attr pp] converts a pretty-printer [pp] to a
+    [Notty.image] using the given [attr] for styling. *)
+val pp : ?attr:Notty.attr -> User_message.Style.t Pp.t -> Notty.image

src/dune_tui/dune

@@ -2,10 +2,15 @@
  (name dune_tui)
  (libraries
   stdune
+  dune_lwd
+  dune_util
+  dune_nottui
   dune_notty
   dune_notty_unix
   dune_console
   dune_threaded_console
   threads.posix)
  (instrumentation
   (backend bisect_ppx)))
+
+(include_subdirs unqualified)