diff --git a/boot/libs.ml b/boot/libs.ml index 2b52339802f..e5c8e15f75b 100644 --- a/boot/libs.ml +++ b/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) diff --git a/doc/changes/8429.md b/doc/changes/8429.md new file mode 100644 index 00000000000..349fac76922 --- /dev/null +++ b/doc/changes/8429.md @@ -0,0 +1,4 @@ +- Added experimental `--display tui` option for Dune that opens an interactive + Terminal User Interface (TUI) when Dune is running. Press '?' to open up a + help screen when running for more information. (#8429, @Alizter and + @rgrinberg) diff --git a/otherlibs/stdune/src/ansi_color.ml b/otherlibs/stdune/src/ansi_color.ml index 35f4bfc1ea1..57a533211c9 100644 --- a/otherlibs/stdune/src/ansi_color.ml +++ b/otherlibs/stdune/src/ansi_color.ml @@ -4,6 +4,7 @@ module RGB8 : sig val to_dyn : t -> Dyn.t val of_int : int -> t val to_int : t -> int + val compare : t -> t -> Ordering.t (** This is only used internally. *) val write_to_buffer : Buffer.t -> t -> unit @@ -13,6 +14,7 @@ end = struct let to_dyn t = Dyn.Int (int_of_char t) let of_int t = char_of_int (t land 0xFF) let to_int t = int_of_char t + let compare t1 t2 = Char.compare t1 t2 let write_to_buffer buf c = Buffer.add_string buf "38;5;"; @@ -24,6 +26,7 @@ module RGB24 : sig type t val to_dyn : t -> Dyn.t + val compare : t -> t -> Ordering.t val red : t -> int val green : t -> int val blue : t -> int @@ -34,6 +37,7 @@ module RGB24 : sig end = struct type t = int + let compare = Int.compare let red t = Int.shift_right t 16 land 0xFF let green t = Int.shift_right t 8 land 0xFF let blue t = t land 0xFF @@ -186,6 +190,134 @@ module Style = struct | `Underline -> Dyn.variant "Underline" [] ;; + let compare (t1 : t) (t2 : t) : Ordering.t = + match t1, t2 with + | `Fg_default, `Fg_default -> Eq + | `Fg_default, _ -> Lt + | _, `Fg_default -> Gt + | `Fg_black, `Fg_black -> Eq + | `Fg_black, _ -> Lt + | _, `Fg_black -> Gt + | `Fg_red, `Fg_red -> Eq + | `Fg_red, _ -> Lt + | _, `Fg_red -> Gt + | `Fg_green, `Fg_green -> Eq + | `Fg_green, _ -> Lt + | _, `Fg_green -> Gt + | `Fg_yellow, `Fg_yellow -> Eq + | `Fg_yellow, _ -> Lt + | _, `Fg_yellow -> Gt + | `Fg_blue, `Fg_blue -> Eq + | `Fg_blue, _ -> Lt + | _, `Fg_blue -> Gt + | `Fg_magenta, `Fg_magenta -> Eq + | `Fg_magenta, _ -> Lt + | _, `Fg_magenta -> Gt + | `Fg_cyan, `Fg_cyan -> Eq + | `Fg_cyan, _ -> Lt + | _, `Fg_cyan -> Gt + | `Fg_white, `Fg_white -> Eq + | `Fg_white, _ -> Lt + | _, `Fg_white -> Gt + | `Fg_bright_black, `Fg_bright_black -> Eq + | `Fg_bright_black, _ -> Lt + | _, `Fg_bright_black -> Gt + | `Fg_bright_red, `Fg_bright_red -> Eq + | `Fg_bright_red, _ -> Lt + | _, `Fg_bright_red -> Gt + | `Fg_bright_green, `Fg_bright_green -> Eq + | `Fg_bright_green, _ -> Lt + | _, `Fg_bright_green -> Gt + | `Fg_bright_yellow, `Fg_bright_yellow -> Eq + | `Fg_bright_yellow, _ -> Lt + | _, `Fg_bright_yellow -> Gt + | `Fg_bright_blue, `Fg_bright_blue -> Eq + | `Fg_bright_blue, _ -> Lt + | _, `Fg_bright_blue -> Gt + | `Fg_bright_magenta, `Fg_bright_magenta -> Eq + | `Fg_bright_magenta, _ -> Lt + | _, `Fg_bright_magenta -> Gt + | `Fg_bright_cyan, `Fg_bright_cyan -> Eq + | `Fg_bright_cyan, _ -> Lt + | _, `Fg_bright_cyan -> Gt + | `Fg_bright_white, `Fg_bright_white -> Eq + | `Fg_bright_white, _ -> Lt + | _, `Fg_bright_white -> Gt + | `Fg_8_bit_color c1, `Fg_8_bit_color c2 -> RGB8.compare c1 c2 + | `Fg_8_bit_color _, _ -> Lt + | _, `Fg_8_bit_color _ -> Gt + | `Fg_24_bit_color c1, `Fg_24_bit_color c2 -> RGB24.compare c1 c2 + | `Fg_24_bit_color _, _ -> Lt + | _, `Fg_24_bit_color _ -> Gt + | `Bg_default, `Bg_default -> Eq + | `Bg_default, _ -> Lt + | _, `Bg_default -> Gt + | `Bg_black, `Bg_black -> Eq + | `Bg_black, _ -> Lt + | _, `Bg_black -> Gt + | `Bg_red, `Bg_red -> Eq + | `Bg_red, _ -> Lt + | _, `Bg_red -> Gt + | `Bg_green, `Bg_green -> Eq + | `Bg_green, _ -> Lt + | _, `Bg_green -> Gt + | `Bg_yellow, `Bg_yellow -> Eq + | `Bg_yellow, _ -> Lt + | _, `Bg_yellow -> Gt + | `Bg_blue, `Bg_blue -> Eq + | `Bg_blue, _ -> Lt + | _, `Bg_blue -> Gt + | `Bg_magenta, `Bg_magenta -> Eq + | `Bg_magenta, _ -> Lt + | _, `Bg_magenta -> Gt + | `Bg_cyan, `Bg_cyan -> Eq + | `Bg_cyan, _ -> Lt + | _, `Bg_cyan -> Gt + | `Bg_white, `Bg_white -> Eq + | `Bg_white, _ -> Lt + | _, `Bg_white -> Gt + | `Bg_bright_black, `Bg_bright_black -> Eq + | `Bg_bright_black, _ -> Lt + | _, `Bg_bright_black -> Gt + | `Bg_bright_red, `Bg_bright_red -> Eq + | `Bg_bright_red, _ -> Lt + | _, `Bg_bright_red -> Gt + | `Bg_bright_green, `Bg_bright_green -> Eq + | `Bg_bright_green, _ -> Lt + | _, `Bg_bright_green -> Gt + | `Bg_bright_yellow, `Bg_bright_yellow -> Eq + | `Bg_bright_yellow, _ -> Lt + | _, `Bg_bright_yellow -> Gt + | `Bg_bright_blue, `Bg_bright_blue -> Eq + | `Bg_bright_blue, _ -> Lt + | _, `Bg_bright_blue -> Gt + | `Bg_bright_magenta, `Bg_bright_magenta -> Eq + | `Bg_bright_magenta, _ -> Lt + | _, `Bg_bright_magenta -> Gt + | `Bg_bright_cyan, `Bg_bright_cyan -> Eq + | `Bg_bright_cyan, _ -> Lt + | _, `Bg_bright_cyan -> Gt + | `Bg_bright_white, `Bg_bright_white -> Eq + | `Bg_bright_white, _ -> Lt + | _, `Bg_bright_white -> Gt + | `Bg_8_bit_color c1, `Bg_8_bit_color c2 -> RGB8.compare c1 c2 + | `Bg_8_bit_color _, _ -> Lt + | _, `Bg_8_bit_color _ -> Gt + | `Bg_24_bit_color c1, `Bg_24_bit_color c2 -> RGB24.compare c1 c2 + | `Bg_24_bit_color _, _ -> Lt + | _, `Bg_24_bit_color _ -> Gt + | `Bold, `Bold -> Eq + | `Bold, _ -> Lt + | _, `Bold -> Gt + | `Dim, `Dim -> Eq + | `Dim, _ -> Lt + | _, `Dim -> Gt + | `Italic, `Italic -> Eq + | `Italic, _ -> Lt + | _, `Italic -> Gt + | `Underline, `Underline -> Eq + ;; + module Of_ansi_code = struct type code = t diff --git a/otherlibs/stdune/src/ansi_color.mli b/otherlibs/stdune/src/ansi_color.mli index 1dc9ef2ec91..ac672c31a5e 100644 --- a/otherlibs/stdune/src/ansi_color.mli +++ b/otherlibs/stdune/src/ansi_color.mli @@ -68,6 +68,7 @@ module Style : sig ] val to_dyn : t -> Dyn.t + val compare : t -> t -> Ordering.t (** Ansi escape sequence that set the terminal style to exactly these styles *) val escape_sequence : t list -> string diff --git a/otherlibs/stdune/src/char.ml b/otherlibs/stdune/src/char.ml index 122fafdad75..1e28e756408 100644 --- a/otherlibs/stdune/src/char.ml +++ b/otherlibs/stdune/src/char.ml @@ -11,3 +11,4 @@ let is_lowercase_hex = function ;; let[@inline always] hash c = Int.hash (code c) +let compare x y = Ordering.of_int (compare x y) diff --git a/otherlibs/stdune/src/char.mli b/otherlibs/stdune/src/char.mli index 84702a93820..cb08cac2b44 100644 --- a/otherlibs/stdune/src/char.mli +++ b/otherlibs/stdune/src/char.mli @@ -9,3 +9,4 @@ val is_digit : t -> bool val is_lowercase_hex : t -> bool val hash : t -> int +val compare : t -> t -> Ordering.t diff --git a/otherlibs/stdune/src/stdune.ml b/otherlibs/stdune/src/stdune.ml index a696eef0583..8228003bf74 100644 --- a/otherlibs/stdune/src/stdune.ml +++ b/otherlibs/stdune/src/stdune.ml @@ -22,7 +22,16 @@ module Map = Map module Option = Option module Or_exn = Or_exn module Ordering = Ordering -module Pp = Pp + +module Pp = struct + include Pp + + (** This version of [Pp.compare] uses [Ordering.t] rather than returning an [int]. *) + let compare ~compare x y = + Ordering.of_int (Pp.compare (fun a b -> Ordering.to_int (compare a b)) x y) + ;; +end + module Result = Result module Set = Set module Signal = Signal diff --git a/otherlibs/stdune/src/user_message.ml b/otherlibs/stdune/src/user_message.ml index 7f9e2372745..c6ed4cd9248 100644 --- a/otherlibs/stdune/src/user_message.ml +++ b/otherlibs/stdune/src/user_message.ml @@ -12,6 +12,44 @@ module Style = struct | Debug | Success | Ansi_styles of Ansi_color.Style.t list + + let compare t1 t2 : Ordering.t = + match t1, t2 with + | Loc, Loc -> Eq + | Loc, _ -> Lt + | _, Loc -> Gt + | Error, Error -> Eq + | Error, _ -> Lt + | _, Error -> Gt + | Warning, Warning -> Eq + | Warning, _ -> Lt + | _, Warning -> Gt + | Kwd, Kwd -> Eq + | Kwd, _ -> Lt + | _, Kwd -> Gt + | Id, Id -> Eq + | Id, _ -> Lt + | _, Id -> Gt + | Prompt, Prompt -> Eq + | Prompt, _ -> Lt + | _, Prompt -> Gt + | Hint, Hint -> Eq + | Hint, _ -> Lt + | _, Hint -> Gt + | Details, Details -> Eq + | Details, _ -> Lt + | _, Details -> Gt + | Ok, Ok -> Eq + | Ok, _ -> Lt + | _, Ok -> Gt + | Debug, Debug -> Eq + | Debug, _ -> Lt + | _, Debug -> Gt + | Success, Success -> Eq + | Success, _ -> Lt + | _, Success -> Gt + | Ansi_styles _, Ansi_styles _ -> Eq + ;; end module Annots = struct diff --git a/otherlibs/stdune/src/user_message.mli b/otherlibs/stdune/src/user_message.mli index ac5845f2f99..64ba91b2dd9 100644 --- a/otherlibs/stdune/src/user_message.mli +++ b/otherlibs/stdune/src/user_message.mli @@ -21,6 +21,8 @@ module Style : sig | Debug | Success | Ansi_styles of Ansi_color.Style.t list + + val compare : t -> t -> Ordering.t end module Annots : sig diff --git a/src/dune_tui/drawing.ml b/src/dune_tui/drawing.ml new file mode 100644 index 00000000000..2a8bde9a4d2 --- /dev/null +++ b/src/dune_tui/drawing.ml @@ -0,0 +1,157 @@ +open Import + +let attr_of_ansi_color_rgb8 (c : Ansi_color.RGB8.t) = + 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) = + 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) = + 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 = + 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_to_image = + Notty.I.strf "%a" (Pp.to_fmt_with_tags ~tag_handler:attr_of_user_message_style) +;; + +module Unicode = struct + let ogham_feather_mark = Uchar.of_int 0x169B + let ogham_reversed_feather_mark = Uchar.of_int 0x169C + let horizontal_bar = Uchar.of_int 0x2015 + let box_drawings_double_horizontal = Uchar.of_int 0x2550 + let box_drawings_double_vertical = Uchar.of_int 0x2551 + let box_drawings_double_down_and_right = Uchar.of_int 0x2554 + let box_drawings_double_down_and_left = Uchar.of_int 0x2557 + let box_drawings_double_up_and_right = Uchar.of_int 0x255A + let box_drawings_double_up_and_left = Uchar.of_int 0x255D + let box_drawings_vertical_single_and_right_double = Uchar.of_int 0x255E + let box_drawings_vertical_single_and_left_double = Uchar.of_int 0x2561 +end + +module Box = struct + let border_box ~attr image = + let w, h = I.(width image, height image) in + let border_element ?(width = 1) ?(height = 1) uchar valign halign = + I.uchar attr uchar width height + |> I.vsnap ~align:valign (h + 2) + |> I.hsnap ~align:halign (w + 2) + in + I.zcat + [ border_element Unicode.box_drawings_double_down_and_right `Top `Left + ; border_element Unicode.box_drawings_double_down_and_left `Top `Right + ; border_element Unicode.box_drawings_double_up_and_right `Bottom `Left + ; border_element Unicode.box_drawings_double_up_and_left `Bottom `Right + ; border_element Unicode.box_drawings_double_horizontal ~width:w `Top `Middle + ; border_element Unicode.box_drawings_double_horizontal ~width:w `Bottom `Middle + ; border_element Unicode.box_drawings_double_vertical ~height:h `Middle `Left + ; border_element Unicode.box_drawings_double_vertical ~height:h `Middle `Right + ; 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 Unicode.box_drawings_vertical_single_and_left_double 1 1 + ; I.string title_attr (" " ^ title ^ " ") + ; I.uchar attr Unicode.box_drawings_vertical_single_and_right_double 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) + ;; +end diff --git a/src/dune_tui/drawing.mli b/src/dune_tui/drawing.mli new file mode 100644 index 00000000000..d6003432bf5 --- /dev/null +++ b/src/dune_tui/drawing.mli @@ -0,0 +1,55 @@ +open Import + +(** Miscellaneous drawing utilities for [Notty.I.t]. *) + +(** [Drawing.pp_to_image pp] converts a [pp] to a [I.t] converting the + [User_message.Style.t] tags into appropriate Notty [A.t]s. *) +val pp_to_image : User_message.Style.t Pp.t -> Notty.image + +module Box : sig + (** [I.t] utilities for drawing boxes. *) + + (** [Box.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 +end + +module Unicode : sig + (** Unicode constants useful for drawing. *) + + (** ᚛ U+169B *) + val ogham_feather_mark : Uchar.t + + (** ᚜ U+169C *) + val ogham_reversed_feather_mark : Uchar.t + + (** ― U+2015 *) + val horizontal_bar : Uchar.t + + (** ═ U+2550 *) + val box_drawings_double_horizontal : Uchar.t + + (** ║ U+2551 *) + val box_drawings_double_vertical : Uchar.t + + (** ╔ U+2554 *) + val box_drawings_double_down_and_right : Uchar.t + + (** ╗ U+2557 *) + val box_drawings_double_down_and_left : Uchar.t + + (** ╚ U+255A *) + val box_drawings_double_up_and_right : Uchar.t + + (** ╝ U+255D *) + val box_drawings_double_up_and_left : Uchar.t + + (** ╞ U+255E *) + val box_drawings_vertical_single_and_right_double : Uchar.t + + (** ╡ U+2561 *) + val box_drawings_vertical_single_and_left_double : Uchar.t +end diff --git a/src/dune_tui/dune b/src/dune_tui/dune index 79116edeae5..e44b04628d2 100644 --- a/src/dune_tui/dune +++ b/src/dune_tui/dune @@ -2,6 +2,9 @@ (name dune_tui) (libraries stdune + dune_lwd + dune_util + dune_nottui dune_notty dune_notty_unix dune_console @@ -9,3 +12,5 @@ threads.posix) (instrumentation (backend bisect_ppx))) + +(include_subdirs unqualified) diff --git a/src/dune_tui/dune_tui.ml b/src/dune_tui/dune_tui.ml index fecedb76391..eef7ee41c6f 100644 --- a/src/dune_tui/dune_tui.ml +++ b/src/dune_tui/dune_tui.ml @@ -1,118 +1,8 @@ -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 image_of_user_message_style_pp = - Notty.I.strf "%a@." (Pp.to_fmt_with_tags ~tag_handler:attr_of_user_message_style) -;; +open Import +open Lwd.O +module Unicode = Drawing.Unicode module Tui = struct - module Term = Notty_unix.Term - let create () = Term.create ~nosig:false ~output:Unix.stderr () let bytes = Bytes.make 64 '0' let sigcont_pipe = lazy (Unix.pipe ~cloexec:true ()) @@ -144,35 +34,303 @@ module Tui = struct fun () -> !(Lazy.force setup) ;; - let start () = () + (* style for diving visual elements like borders or rules *) + let divider_attr = A.(fg red) + + (* style for helpful ui elements like scrollbar structures or help text *) + let helper_attr = A.(fg yellow) + + (* style for user feedback like message count, or scrollbar position *) + let user_feedback_attr = A.(fg cyan) + + (* [horizontal_rule ~attr ~w] draws a horizontal line with [attr] of length [w]. *) + let horiztonal_rule ~attr ~w = I.uchar attr Drawing.Unicode.horizontal_bar w 1 + + (* Here we keep some persistent state about the program that we udpate each time we + render. This allows other components to "react" to changes using [Lwd]. *) + + let term_size = Lwd.var (0, 0) + let messages = Lwd.var [] + let status_line = Lwd.var None + + module Message_viewer = struct + (* Specialized widget for viewing messages in a list. *) + + (* [is_message_hidden] tracks if a given message is hidden. [true] means it is hidden + and [false] means it is expanded. *) + let is_message_hidden = Lwd.var (fun _ -> false) - let image ~status_line ~messages = + let message_images = + let+ messages = Lwd.get messages in + List.map messages ~f:(fun x -> Drawing.pp_to_image (User_message.pp x)) + ;; + + (* We calculate the max message length from all the messages. This is used to keep + the horizontal lines with a consistent length. *) + let max_message_length = + let+ messages = message_images + and+ w, _ = Lwd.get term_size in + let lengths = List.map messages ~f:I.width in + match List.max lengths ~f:Int.compare with + | None -> w - 1 + | Some l -> max l w + ;; + + (* We approximate the first line of the message. Unfortunately due to the way Notty + images work, it is not easy to get the actual width of the first line. Therefore + we just chop a third off as an approximation. *) + let message_synopsis ~attr = + let+ messages = message_images + and+ width, _ = Lwd.get term_size in + fun index -> + match List.nth messages index with + | None -> I.string attr "..." + | Some message -> + let cropped_image = I.vcrop 0 (I.height message - 1) message in + I.hcrop 0 (min (I.width cropped_image / 3) (width - 15)) cropped_image + ;; + + (* This is a line that shows the total number of messages and the message count used + for separating messages. It also has a handler for clicks that minimizes the + message. *) + let horizontal_line_with_count total index = + let+ is_hidden = Lwd.get is_message_hidden + and+ w = max_message_length + and+ synopsis = Lwd.app (message_synopsis ~attr:helper_attr) (Lwd.return index) in + let index_is_hidden = is_hidden index in + let status = + I.hcat + [ I.uchar divider_attr Unicode.ogham_reversed_feather_mark 1 1 + ; I.string user_feedback_attr (string_of_int (index + 1)) + ; I.string divider_attr "/" + ; I.string user_feedback_attr (string_of_int total) + ; I.uchar divider_attr Unicode.ogham_feather_mark 1 1 + ] + in + let toggle_indicator = + I.hcat + [ I.uchar divider_attr Unicode.ogham_reversed_feather_mark 1 1 + ; (if index_is_hidden + then I.string helper_attr "+" + else I.string helper_attr "-") + ; I.uchar divider_attr Unicode.ogham_feather_mark 1 1 + ] + in + let synopsis = + if index_is_hidden + then + I.hcat + [ I.hpad 1 0 @@ I.uchar divider_attr Unicode.ogham_reversed_feather_mark 1 1 + ; synopsis + ; I.uchar divider_attr Unicode.ogham_feather_mark 1 1 + ] + else I.empty + in + let mouse_handler ~x:_ ~y = function + | `Left -> + if y = 0 + then ( + Lwd.set is_message_hidden (fun x -> + if x = index then not index_is_hidden else is_hidden x); + `Handled) + else `Unhandled + | _ -> `Unhandled + in + Ui.atom + @@ I.zcat + I. + [ I.hsnap ~align:`Left w (toggle_indicator <|> status <|> synopsis) + ; horiztonal_rule ~w ~attr:divider_attr + ] + |> Ui.mouse_area mouse_handler + ;; + + (* This components displays a line followed by a message. Cliking on the line will + collapse the message. *) + let line_separated_message ~total index msg = + let+ horizontal_line_with_count = horizontal_line_with_count total index + and+ toggle = Lwd.app (Lwd.get is_message_hidden) (Lwd.return index) in + if toggle + then horizontal_line_with_count + else Ui.vcat [ horizontal_line_with_count; Ui.atom msg ] + ;; + + (* We take all the messages in the console and display them as + [line_separated_message]s. We also handle arrow keys/vim bindings together with + mouse scrolling for the scrolling effect. We handle ['m'] as an expand / + collapse all messages function. *) + let ui = + let expand_all = Lwd.var false in + let scrollbox_state = Lwd.var Scrollbox.State.init in + let* messages = message_images + and+ w = max_message_length in + let+ { ui; vscroll; hscroll } = + let image = + let+ messages = + List.mapi messages ~f:(line_separated_message ~total:(List.length messages)) + |> Lwd_utils.flatten_l + in + match messages with + | [] -> Ui.empty + | messages -> + Ui.vcat (messages @ [ Ui.atom @@ horiztonal_rule ~w ~attr:helper_attr ]) + in + Scrollbox.make scrollbox_state @@ image + in + let keyboard_handler : Ui.key -> Ui.may_handle = function + (* Arrow keys and vim bindings can also scroll *) + | (`Arrow `Down | `ASCII 'j'), _ -> + vscroll ~dir:`Down; + `Handled + | (`Arrow `Up | `ASCII 'k'), _ -> + vscroll ~dir:`Up; + `Handled + | (`Arrow `Left | `ASCII 'h'), _ -> + hscroll ~dir:`Left; + `Handled + | (`Arrow `Right | `ASCII 'l'), _ -> + hscroll ~dir:`Right; + `Handled + (* Toggle expand all *) + | `ASCII 'm', _ -> + Lwd.set expand_all (not (Lwd.peek expand_all)); + Lwd.set is_message_hidden (fun _ -> Lwd.peek expand_all); + `Handled + | _ -> `Unhandled + in + let mouse_handler ~x:_ ~y:_ = function + | `Scroll dir -> + vscroll ~dir; + `Handled + | _ -> `Unhandled + in + ui |> Ui.keyboard_area keyboard_handler |> Ui.mouse_area mouse_handler + ;; + end + + (* Help pop up contains help information for the user. It also includes a hook so that + other compoenents can trigger the help screen. *) + let help_box = + let help_screen_lines = + [ "Press 'q' to quit" + ; "Press '?' to toggle this screen" + ; "Navigate with the mouse or arrow keys (or vim bindings)" + ; "Press 'm' to expand / collapse all messages" + ] + in + let* width, height = Lwd.get term_size in + Help_box.make ~helper_attr ~divider_attr ~help_screen_lines ~width ~height + ;; + + (* The status bar shows the build status and includes a help button. *) + let status_bar = + let+ w, _ = Lwd.get term_size + and+ help_button = + let+ { toggle; _ } = help_box in + let image = + I.hcat + [ I.uchar helper_attr Unicode.ogham_reversed_feather_mark 1 1 + ; I.char user_feedback_attr '?' 1 1 + ; I.uchar helper_attr Unicode.ogham_feather_mark 1 1 + ] + in + Button.of_ (Ui.atom image) toggle + and+ status = + Lwd.get status_line + >>| function + | None -> I.empty + | Some message -> Drawing.pp_to_image message + in let status = - match (status_line : User_message.Style.t Pp.t option) with - | None -> [] - | Some message -> [ image_of_user_message_style_pp message ] + I.hcat + [ I.uchar helper_attr Unicode.ogham_reversed_feather_mark 1 1 + ; I.char helper_attr ' ' 1 1 + ; status + ; I.char helper_attr ' ' 1 1 + ; I.uchar helper_attr Unicode.ogham_feather_mark 1 1 + ] in - let messages = - List.map messages ~f:(fun msg -> - image_of_user_message_style_pp (User_message.pp msg)) + let hsnap_or_leave ~width img = + if I.width img < width then I.hsnap ~align:`Middle width img else img in - Notty.I.vcat (messages @ status) + Ui.zcat + [ Ui.atom + @@ I.zcat [ hsnap_or_leave ~width:w status; horiztonal_rule ~attr:helper_attr ~w ] + ; help_button + ] + ;; + + (* Our document has 3 components: + - A help box + - A status bar + - A message viewer *) + let document = + let* { ui = help_box; toggle = handle_help } = help_box in + let+ status_bar = status_bar + and+ message_viewer = Message_viewer.ui in + let keyboard_handler = function + (* When we encounter q we make sure to quit by signaling termination. *) + | `ASCII 'q', _ -> + Unix.kill (Unix.getpid ()) Sys.sigterm; + `Handled + (* Toggle help screen *) + | `ASCII '?', _ -> + handle_help (); + `Handled + | _ -> `Unhandled + in + Ui.zcat [ Ui.vcat [ status_bar; message_viewer ]; help_box ] + |> Ui.keyboard_area keyboard_handler + ;; + + let renderer = Renderer.make () + + let set_state = + let update equal v x = if not (equal (Lwd.peek v) x) then Lwd.set v x in + fun (state : Dune_threaded_console.state) -> + let size = Term.size (term ()) in + update (Tuple.T2.equal Int.equal Int.equal) term_size size; + update + (Option.equal (fun x y -> + Ordering.is_eq (Pp.compare ~compare:User_message.Style.compare x y))) + status_line + state.status_line; + if let l = Lwd.peek messages in + not + (List.length l = Queue.length state.messages + && List.equal User_message.equal l (Queue.to_list state.messages)) + then Lwd.set messages (Queue.to_list state.messages) ;; 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 + let size = Term.size (term ()) in + (* Update the persistant values tracked by other components. *) + set_state state; + (* This is a standard [Lwd] routine for creating a document. *) + let root = Lwd.observe document in + let image = + let rec stabilize () = + let tree = Lwd.quick_sample root in + Renderer.update renderer size tree; + let image = Renderer.image renderer in + if Lwd.is_damaged root then stabilize () else image + in + stabilize () + in + (* Finally we use Notty to show the image. *) Term.image (term ()) image ;; - let resize mutex (state : Dune_threaded_console.state) = + (* Update any global state and finish *) + let set_dirty ~mutex (state : Dune_threaded_console.state) = Mutex.lock mutex; state.dirty <- true; Mutex.unlock mutex; Unix.gettimeofday () ;; - let rec handle_user_events ~now ~time_budget mutex state = + let rec handle_user_events ~now ~time_budget mutex (state : Dune_threaded_console.state) + = (* We check for any user input and handle it. If we go over the [time_budget] we give up and continue. *) let input_fds = @@ -192,20 +350,19 @@ module Tui = struct `Restore) in match input_fds with - | `Restore -> resize mutex state + | `Restore -> set_dirty ~mutex state | `Timeout -> now +. time_budget (* Nothing to do, we return the time at the end of the time budget. *) | `Event -> - (* 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 () - | `Resize _ -> resize mutex state - | _ -> Unix.gettimeofday () + | `End -> set_dirty ~mutex state + (* on resize we wish to redraw so the state is set to dirty *) + | `Resize (_width, _height) -> set_dirty ~mutex state + | #Notty.Unescape.event as event -> + let event = (event : Notty.Unescape.event :> Ui.event) in + ignore (Renderer.dispatch_event renderer event : [ `Handled | `Unhandled ]); + set_dirty ~mutex state | exception Unix.Unix_error ((EAGAIN | EWOULDBLOCK), _, _) -> (* If we encounter an exception, we make sure to rehandle user events with a corrected time budget. *) @@ -216,6 +373,7 @@ module Tui = struct handle_user_events ~now ~time_budget mutex state) ;; + let start () = () let reset () = () let reset_flush_history () = () let finish () = Term.release (term ()) diff --git a/src/dune_tui/import.ml b/src/dune_tui/import.ml new file mode 100644 index 00000000000..e2232da2dab --- /dev/null +++ b/src/dune_tui/import.ml @@ -0,0 +1,17 @@ +include Stdune +module Ui = Nottui.Ui +module Term = Notty_unix.Term +module A = Notty.A +module I = Notty.I +module Renderer = Nottui.Renderer + +module Lwd = struct + module O = struct + let ( let+ ) x f = Lwd.map x ~f + let ( let* ) x f = Lwd.bind x ~f + let ( >>| ) x f = Lwd.map x ~f + let ( and+ ) x y = Lwd.pair x y + end + + include Lwd +end diff --git a/src/dune_tui/widgets/button.ml b/src/dune_tui/widgets/button.ml new file mode 100644 index 00000000000..d0ad35bcb63 --- /dev/null +++ b/src/dune_tui/widgets/button.ml @@ -0,0 +1,9 @@ +open Import + +let of_ ui f = + Ui.mouse_area + (fun ~x:_ ~y:_ _ -> + f (); + `Handled) + ui +;; diff --git a/src/dune_tui/widgets/button.mli b/src/dune_tui/widgets/button.mli new file mode 100644 index 00000000000..3bf32e7ac41 --- /dev/null +++ b/src/dune_tui/widgets/button.mli @@ -0,0 +1,5 @@ +open Import + +(** [Button.of_ ui f] turns the given [ui] into a clickable button that calls [f] when + clicked. *) +val of_ : Ui.t -> (unit -> unit) -> Ui.t diff --git a/src/dune_tui/widgets/help_box.ml b/src/dune_tui/widgets/help_box.ml new file mode 100644 index 00000000000..d148618a538 --- /dev/null +++ b/src/dune_tui/widgets/help_box.ml @@ -0,0 +1,63 @@ +open Import +open Lwd.O + +let hsnap_or_leave ~width img = + if I.width img < width then I.hsnap ~align:`Middle width img else img +;; + +let vsnap_or_leave ~height img = + if I.height img < height then I.vsnap ~align:`Middle height img else img +;; + +let dialogue_box ~attr ~title ~title_attr ~width ~height image = + Drawing.Box.with_title ~attr ~title ~title_attr image + |> vsnap_or_leave ~height + |> hsnap_or_leave ~width +;; + +type t = + { ui : Ui.t + ; toggle : unit -> unit + } + +let make = + let help_screen_enabled = Lwd.var false in + let handle_help () = Lwd.set help_screen_enabled (not (Lwd.peek help_screen_enabled)) in + fun ~helper_attr ~divider_attr ~help_screen_lines ~width ~height -> + let+ ui = + Lwd.get help_screen_enabled + >>| function + | false -> Ui.empty + | true -> + let image = + let img = List.map help_screen_lines ~f:(I.string helper_attr) |> I.vcat in + [ img + ; I.string A.empty "" + ; I.string helper_attr "🐪 Developed by the Dune team 🐪" + |> I.hsnap ~align:`Middle (I.width img) + ] + |> I.vcat + |> I.pad ~l:1 ~r:1 ~t:1 ~b:1 + |> dialogue_box + ~attr:divider_attr + ~title:"Help" + ~title_attr:helper_attr + ~width + ~height + in + (* Any mouse actions should close the help screen. *) + let mouse_handler ~x:_ ~y:_ = function + | `Left | `Middle | `Right | `Scroll _ -> + handle_help (); + `Handled + in + (* Any keyboard actions should close the help screen. *) + let keyboard_handler : Ui.key -> Ui.may_handle = function + | _ -> + handle_help (); + `Handled + in + Ui.atom image |> Ui.mouse_area mouse_handler |> Ui.keyboard_area keyboard_handler + in + { ui; toggle = handle_help } +;; diff --git a/src/dune_tui/widgets/help_box.mli b/src/dune_tui/widgets/help_box.mli new file mode 100644 index 00000000000..6180b6d1f9f --- /dev/null +++ b/src/dune_tui/widgets/help_box.mli @@ -0,0 +1,14 @@ +open Import + +type t = + { ui : Ui.t + ; toggle : unit -> unit + } + +val make + : helper_attr:A.t + -> divider_attr:A.t + -> help_screen_lines:string list + -> width:int + -> height:int + -> t Lwd.t diff --git a/src/dune_tui/widgets/scrollbox.ml b/src/dune_tui/widgets/scrollbox.ml new file mode 100644 index 00000000000..35392cc7cef --- /dev/null +++ b/src/dune_tui/widgets/scrollbox.ml @@ -0,0 +1,164 @@ +open Import + +module State = struct + type t = + { width : int + ; height : int + ; x : int + ; y : int + } + + let init = { width = 0; height = 0; x = 0; y = 0 } +end + +let adjust_offset visible total off = + let off = if off + visible > total then total - visible else off in + let off = if off < 0 then 0 else off in + off +;; + +let decr_if x cond = if cond then x - 1 else x +let scrollbar_bg = Notty.A.gray 4 +let scrollbar_fg = Notty.A.gray 7 +let scrollbar_click_step = 3 (* Clicking scrolls one third of the screen *) +let scrollbar_wheel_step = 8 (* Wheel event scrolls 1/8th of the screen *) + +let scroll visible offset ~set ~dir = + let dir = + match dir with + | `Down -> 1 + | `Up -> -1 + in + set (offset + (dir * max 1 (visible / scrollbar_wheel_step))) +;; + +let hscrollbar visible total offset ~set = + let prefix = offset * visible / total in + let suffix = (total - offset - visible) * visible / total in + let handle = visible - prefix - suffix in + let render size color = Ui.atom Notty.(I.char (A.bg color) ' ' size 1) in + let mouse_handler ~x ~y:_ = function + | `Left -> + if x < prefix + then ( + set (offset - max 1 (visible / scrollbar_click_step)); + `Handled) + else if x > prefix + handle + then ( + set (offset + max 1 (visible / scrollbar_click_step)); + `Handled) + else + `Grab + ( (fun ~x:x' ~y:_ -> set (offset + ((x' - x) * total / visible))) + , fun ~x:_ ~y:_ -> () ) + | `Scroll dir -> + scroll visible offset ~set ~dir; + `Handled + | _ -> `Unhandled + in + let ( ++ ) = Ui.join_x in + Ui.mouse_area + mouse_handler + (render prefix scrollbar_bg + ++ render handle scrollbar_fg + ++ render suffix scrollbar_bg) +;; + +let vscrollbar visible total offset ~set = + let prefix = offset * visible / total in + let suffix = (total - offset - visible) * visible / total in + let handle = visible - prefix - suffix in + let render size color = Ui.atom Notty.(I.char (A.bg color) ' ' 1 size) in + let mouse_handler ~x:_ ~y = function + | `Left -> + if y < prefix + then ( + set (offset - max 1 (visible / scrollbar_click_step)); + `Handled) + else if y > prefix + handle + then ( + set (offset + max 1 (visible / scrollbar_click_step)); + `Handled) + else + `Grab + ( (fun ~x:_ ~y:y' -> set (offset + ((y' - y) * total / visible))) + , fun ~x:_ ~y:_ -> () ) + | `Scroll dir -> + scroll visible offset ~set ~dir; + `Handled + | _ -> `Unhandled + in + let ( ++ ) = Ui.join_y in + Ui.mouse_area + mouse_handler + (render prefix scrollbar_bg + ++ render handle scrollbar_fg + ++ render suffix scrollbar_bg) +;; + +type t = + { ui : Ui.t + ; vscroll : dir:[ `Down | `Up ] -> unit + ; hscroll : dir:[ `Right | `Left ] -> unit + } + +let make (state_var : State.t Lwd.var) t = + (* Keep track of size available for display *) + let update_size ~w:width ~h:height = + let state = Lwd.peek state_var in + if state.width <> width || state.height <> height + then Lwd.set state_var { state with width; height } + in + let measure_size body = + Ui.size_sensor update_size (Ui.resize ~w:0 ~h:0 ~sw:1 ~sh:1 body) + in + (* Given body and state, composite scroll bars *) + let compose_bars body (state : State.t) = + let bw, bh = Ui.layout_width body, Ui.layout_height body in + (* Logic to determine which scroll bar should be visible *) + let hvisible = state.width < bw + and vvisible = state.height < bh in + let hvisible = hvisible || (vvisible && state.width = bw) in + let vvisible = vvisible || (hvisible && state.height = bh) in + (* Compute size and offsets based on visibility *) + let state_w = decr_if state.width vvisible in + let state_h = decr_if state.height hvisible in + let state_x = adjust_offset state_w bw state.x in + let state_y = adjust_offset state_h bh state.y in + (* Composite visible scroll bars *) + let crop b = Ui.resize ~sw:1 ~sh:1 ~w:0 ~h:0 (Ui.shift_area state_x state_y b) in + let set_vscroll y = + let state = Lwd.peek state_var in + if state.y <> y then Lwd.set state_var { state with y } + in + let set_hscroll x = + let state = Lwd.peek state_var in + if state.x <> x then Lwd.set state_var { state with x } + in + let ( <-> ) = Ui.join_y + and ( <|> ) = Ui.join_x in + ( (match hvisible, vvisible with + | false, false -> body + | false, true -> crop body <|> vscrollbar state_h bh state_y ~set:set_vscroll + | true, false -> crop body <-> hscrollbar state_w bw state_x ~set:set_hscroll + | true, true -> + crop body + <|> vscrollbar state_h bh state_y ~set:set_vscroll + <-> (hscrollbar state_w bw state_x ~set:set_hscroll <|> Ui.space 1 1)) + , scroll state_h state_y ~set:set_vscroll + , scroll state_w state_x ~set:set_hscroll ) + in + let open Lwd.O in + let+ ui = t + and+ size = Lwd.get state_var in + (* Render final box *) + let box, vscroll, hscroll = compose_bars ui size in + let hscroll ~dir = + hscroll + ~dir: + (match dir with + | `Right -> `Down + | `Left -> `Up) + in + { ui = measure_size box; vscroll; hscroll } +;; diff --git a/src/dune_tui/widgets/scrollbox.mli b/src/dune_tui/widgets/scrollbox.mli new file mode 100644 index 00000000000..e32375a5ef9 --- /dev/null +++ b/src/dune_tui/widgets/scrollbox.mli @@ -0,0 +1,15 @@ +open Import + +module State : sig + type t + + val init : t +end + +type t = + { ui : Ui.t + ; vscroll : dir:[ `Up | `Down ] -> unit + ; hscroll : dir:[ `Left | `Right ] -> unit + } + +val make : State.t Lwd.var -> Ui.t Lwd.t -> t Lwd.t diff --git a/vendor/lwd/LICENSE b/vendor/lwd/LICENSE new file mode 100644 index 00000000000..d9cc7c86a51 --- /dev/null +++ b/vendor/lwd/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2019 Frédéric Bour + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/vendor/lwd/lwd/dune b/vendor/lwd/lwd/dune new file mode 100644 index 00000000000..a0a0d1ecd01 --- /dev/null +++ b/vendor/lwd/lwd/dune @@ -0,0 +1,4 @@ +(library + (name dune_lwd) + (modules lwd lwd_utils) + (wrapped false)) diff --git a/vendor/lwd/lwd/lwd.ml b/vendor/lwd/lwd/lwd.ml new file mode 100644 index 00000000000..3c77a27dab8 --- /dev/null +++ b/vendor/lwd/lwd/lwd.ml @@ -0,0 +1,711 @@ +(** Create-only version of [Obj.t] *) +module Any : sig + type t + val any : 'a -> t +end = struct + type t = Obj.t + let any = Obj.repr +end + +type 'a eval = + | Eval_none + | Eval_progress + | Eval_some of 'a + +type 'a t_ = + | Pure of 'a + | Operator : { + mutable value : 'a eval; (* cached value *) + mutable trace : trace; (* list of parents this can invalidate *) + mutable trace_idx : trace_idx; (* list of direct children that can invalidate this *) + desc: 'a desc; + } -> 'a t_ + | Root : { + mutable value : 'a eval; (* cached value *) + mutable trace_idx : trace_idx; (* list of direct children that can invalidate this *) + mutable on_invalidate : 'a -> unit; + mutable acquired : bool; + child : 'a t_; + } -> 'a t_ + +and _ desc = + | Map : 'a t_ * ('a -> 'b) -> 'b desc + | Map2 : 'a t_ * 'b t_ * ('a -> 'b -> 'c) -> 'c desc + | Pair : 'a t_ * 'b t_ -> ('a * 'b) desc + | App : ('a -> 'b) t_ * 'a t_ -> 'b desc + | Join : { child : 'a t_ t_; mutable intermediate : 'a t_ option } -> 'a desc + | Var : { mutable binding : 'a } -> 'a desc + | Prim : { acquire : 'a t -> 'a; + release : 'a t -> 'a -> unit } -> 'a desc + | Fix : { doc : 'a t_; wrt : _ t_ } -> 'a desc + +(* a set of (active) parents for a ['a t], used during invalidation *) +and trace = + | T0 + | T1 : _ t_ -> trace + | T2 : _ t_ * _ t_ -> trace + | T3 : _ t_ * _ t_ * _ t_ -> trace + | T4 : _ t_ * _ t_ * _ t_ * _ t_ -> trace + | Tn : { mutable active : int; mutable count : int; + mutable entries : Any.t t_ array } -> trace + +(* a set of direct children for a composite document *) +and trace_idx = + | I0 + | I1 : { mutable idx : int ; + obj : 'a t_; + mutable next : trace_idx } -> trace_idx + +(* The type system cannot see that t is covariant in its parameter. + Use the Force to convince it. *) +and +'a t +external inj : 'a t_ -> 'a t = "%identity" +external prj : 'a t -> 'a t_ = "%identity" +external prj2 : 'a t t -> 'a t_ t_ = "%identity" + +(* Basic combinators *) +let return x = inj (Pure x) +let pure x = inj (Pure x) + +let is_pure x = match prj x with + | Pure x -> Some x + | _ -> None + +let dummy = Pure (Any.any ()) + +let operator desc = + Operator { value = Eval_none; trace = T0; desc; trace_idx = I0 } + +let map x ~f = inj ( + match prj x with + | Pure vx -> Pure (f vx) + | x -> operator (Map (x, f)) + ) + +let map2 x y ~f = inj ( + match prj x, prj y with + | Pure vx, Pure vy -> Pure (f vx vy) + | x, y -> operator (Map2 (x, y, f)) + ) + +let pair x y = inj ( + match prj x, prj y with + | Pure vx, Pure vy -> Pure (vx, vy) + | x, y -> operator (Pair (x, y)) + ) + +let app f x = inj ( + match prj f, prj x with + | Pure vf, Pure vx -> Pure (vf vx) + | f, x -> operator (App (f, x)) + ) + +let join child = inj ( + match prj2 child with + | Pure v -> v + | child -> operator (Join { child; intermediate = None }) + ) + +let bind x ~f = join (map ~f x) + +(* Management of trace indices *) + +let addr oc obj = + Printf.fprintf oc "0x%08x" (Obj.magic obj : int) + +external t_equal : _ t_ -> _ t_ -> bool = "%eq" +external obj_t : 'a t_ -> Any.t t_ = "%identity" + +let rec dump_trace : type a. a t_ -> unit = + fun obj -> match obj with + | Pure _ -> Printf.eprintf "%a: Pure _\n%!" addr obj + | Operator t -> + Printf.eprintf "%a: Operator _ -> %a\n%!" addr obj dump_trace_aux t.trace; + begin match t.trace with + | T0 -> () + | T1 a -> dump_trace a + | T2 (a,b) -> dump_trace a; dump_trace b + | T3 (a,b,c) -> dump_trace a; dump_trace b; dump_trace c + | T4 (a,b,c,d) -> dump_trace a; dump_trace b; dump_trace c; dump_trace d + | Tn t -> Array.iter dump_trace t.entries + end + | Root _ -> Printf.eprintf "%a: Root _\n%!" addr obj + +and dump_trace_aux oc = function + | T0 -> Printf.fprintf oc "T0" + | T1 a -> Printf.fprintf oc "T1 %a" addr a + | T2 (a,b) -> + Printf.fprintf oc "T2 (%a, %a)" addr a addr b + | T3 (a,b,c) -> + Printf.fprintf oc "T3 (%a, %a, %a)" addr a addr b addr c + | T4 (a,b,c,d) -> + Printf.fprintf oc "T4 (%a, %a, %a, %a)" addr a addr b addr c addr d + | Tn t -> + Printf.fprintf oc "Tn {active = %d; count = %d; entries = " + t.active t.count; + Array.iter (Printf.fprintf oc "(%a)" addr) t.entries; + Printf.fprintf oc "}" + +let dump_trace x = dump_trace (obj_t (prj x)) + +let add_idx obj idx = function + | Pure _ -> assert false + | Root t' -> t'.trace_idx <- I1 { idx; obj; next = t'.trace_idx } + | Operator t' -> t'.trace_idx <- I1 { idx; obj; next = t'.trace_idx } + +let rec rem_idx_rec obj = function + | I0 -> assert false + | I1 t as self -> + if t_equal t.obj obj + then (t.idx, t.next) + else ( + let idx, result = rem_idx_rec obj t.next in + t.next <- result; + (idx, self) + ) + +(* remove [obj] from the lwd's trace. *) +let rem_idx obj = function + | Pure _ -> assert false + | Root t' -> + let idx, trace_idx = rem_idx_rec obj t'.trace_idx in + t'.trace_idx <- trace_idx; idx + | Operator t' -> + let idx, trace_idx = rem_idx_rec obj t'.trace_idx in + t'.trace_idx <- trace_idx; idx + +(* move [obj] from old index to new index. *) +let rec mov_idx_rec obj oldidx newidx = function + | I0 -> assert false + | I1 t -> + if t.idx = oldidx && t_equal t.obj obj + then t.idx <- newidx + else mov_idx_rec obj oldidx newidx t.next + +let mov_idx obj oldidx newidx = function + | Pure _ -> assert false + | Root t' -> mov_idx_rec obj oldidx newidx t'.trace_idx + | Operator t' -> mov_idx_rec obj oldidx newidx t'.trace_idx + +let rec get_idx_rec obj = function + | I0 -> assert false + | I1 t -> + if t_equal t.obj obj + then t.idx + else get_idx_rec obj t.next + +(* find index of [obj] in the given lwd *) +let get_idx obj = function + | Pure _ -> assert false + | Root t' -> get_idx_rec obj t'.trace_idx + | Operator t' -> get_idx_rec obj t'.trace_idx + +type status = + | Neutral + | Safe + | Unsafe + +type sensitivity = + | Strong + | Fragile + +(* Propagating invalidation recursively. + Each document is invalidated at most once, + and only if it has [t.value = Some _]. *) +let rec invalidate_node : type a . status ref -> sensitivity -> a t_ -> unit = + fun status sensitivity node -> + match node, sensitivity with + | Pure _, _ -> assert false + | Root ({value; _} as t), _ -> + t.value <- Eval_none; + begin match value with + | Eval_none -> () + | Eval_progress -> + status := Unsafe + | Eval_some x -> + begin match sensitivity with + | Strong -> () + | Fragile -> status := Unsafe + end; + t.on_invalidate x (* user callback that {i observes} this root. *) + end + | Operator {value = Eval_none; _}, Fragile -> + begin match !status with + | Unsafe | Safe -> () + | _ -> status := Safe + end + | Operator {value = Eval_none; _}, _ -> () + | Operator {desc = Fix {wrt = Operator {value = Eval_none; _}; _}; _}, Fragile -> + begin match !status with + | Safe | Unsafe -> () + | Neutral -> status := Safe + end + | Operator {desc = Fix {wrt = Operator {value = Eval_some _; _}; _}; _}, Fragile -> + () + | Operator t, _ -> + let sensitivity = + match t.value with Eval_progress -> Fragile | _ -> sensitivity + in + t.value <- Eval_none; + (* invalidate parents recursively *) + invalidate_trace status sensitivity t.trace + +(* invalidate recursively documents in the given trace *) +and invalidate_trace status sensitivity = function + | T0 -> () + | T1 x -> invalidate_node status sensitivity x + | T2 (x, y) -> + invalidate_node status sensitivity x; + invalidate_node status sensitivity y + | T3 (x, y, z) -> + invalidate_node status sensitivity x; + invalidate_node status sensitivity y; + invalidate_node status sensitivity z + | T4 (x, y, z, w) -> + invalidate_node status sensitivity x; + invalidate_node status sensitivity y; + invalidate_node status sensitivity z; + invalidate_node status sensitivity w + | Tn t -> + let active = t.active in + t.active <- 0; + for i = 0 to active - 1 do + invalidate_node status sensitivity t.entries.(i) + done + +let default_unsafe_mutation_logger () = + let callstack = Printexc.get_callstack 20 in + Printf.fprintf stderr + "Lwd: unsafe mutation (variable invalidated during evaluation) at\n%a" + Printexc.print_raw_backtrace callstack + +let unsafe_mutation_logger = ref default_unsafe_mutation_logger + +let do_invalidate sensitivity node = + let status = ref Neutral in + invalidate_node status sensitivity node; + let unsafe = + match !status with + | Neutral | Safe -> false + | Unsafe -> true + in + if unsafe then !unsafe_mutation_logger () + +(* Variables *) +type 'a var = 'a t_ +let var x = operator (Var {binding = x}) +let get x = inj x + +let set (vx:_ var) x : unit = + match vx with + | Operator ({desc = Var v; _}) -> + (* set the variable, and invalidate all observers *) + do_invalidate Strong vx; + v.binding <- x + | _ -> assert false + +let peek = function + | Operator ({desc = Var v; _}) -> v.binding + | _ -> assert false + +(* Primitives *) +type 'a prim = 'a t +let prim ~acquire ~release = + inj (operator (Prim { acquire; release })) +let get_prim x = x + +let invalidate x = match prj x with + | Operator {desc = Prim p; value; _} as t -> + (* the value is invalidated, be sure to invalidate all parents as well *) + begin match value with + | Eval_none -> () + | Eval_progress -> do_invalidate Fragile t; + | Eval_some v -> + do_invalidate Strong t; + p.release x v + end + | _ -> assert false + +(* Fix point *) + +let fix doc ~wrt = match prj wrt with + | Root _ -> assert false + | Pure _ -> doc + | Operator _ as wrt -> inj (operator (Fix {doc = prj doc; wrt})) + +type release_list = + | Release_done + | Release_more : + { origin : 'a t_; element : 'b t_; next : release_list } -> release_list + +type release_queue = release_list ref +let make_release_queue () = ref Release_done + +type release_failure = exn * Printexc.raw_backtrace + +(* [sub_release [] origin self] is called when [origin] is released, + where [origin] is reachable from [self]'s trace. + We're going to remove [origin] from that trace as [origin] is now dead. + + [sub_release] cannot raise. + If a primitive raises, the exception is caught and a warning is emitted. *) +let rec sub_release + : type a b . release_failure list -> a t_ -> b t_ -> release_failure list + = fun failures origin -> function + | Root _ -> assert false + | Pure _ -> failures + | Operator t as self -> + (* compute [t.trace \ {origin}] *) + let trace = match t.trace with + | T0 -> assert false + | T1 x -> assert (t_equal x origin); T0 + | T2 (x, y) -> + if t_equal x origin then T1 y + else if t_equal y origin then T1 x + else assert false + | T3 (x, y, z) -> + if t_equal x origin then T2 (y, z) + else if t_equal y origin then T2 (x, z) + else if t_equal z origin then T2 (x, y) + else assert false + | T4 (x, y, z, w) -> + if t_equal x origin then T3 (y, z, w) + else if t_equal y origin then T3 (x, z, w) + else if t_equal z origin then T3 (x, y, w) + else if t_equal w origin then T3 (x, y, z) + else assert false + | Tn tn as trace -> + let revidx = rem_idx self origin in + assert (t_equal tn.entries.(revidx) origin); + let count = tn.count - 1 in + tn.count <- count; + if revidx < count then ( + let obj = tn.entries.(count) in + tn.entries.(revidx) <- obj; + tn.entries.(count) <- dummy; + mov_idx self count revidx obj + ) else + tn.entries.(revidx) <- dummy; + if tn.active > count then tn.active <- count; + if count = 4 then ( + (* downgrade to [T4] to save space *) + let a = tn.entries.(0) and b = tn.entries.(1) in + let c = tn.entries.(2) and d = tn.entries.(3) in + ignore (rem_idx self a : int); + ignore (rem_idx self b : int); + ignore (rem_idx self c : int); + ignore (rem_idx self d : int); + T4 (a, b, c, d) + ) else ( + let len = Array.length tn.entries in + if count <= len lsr 2 then + Tn { active = tn.active; count = tn.count; + entries = Array.sub tn.entries 0 (len lsr 1) } + else + trace + ) + in + t.trace <- trace; + match trace with + | T0 -> + (* [self] is not active anymore, since it's not reachable + from any root. We can release its cached value and + recursively release its subtree. *) + let value = t.value in + t.value <- Eval_progress; + begin match t.desc with + | Map (x, _) -> sub_release failures self x + | Map2 (x, y, _) -> + sub_release (sub_release failures self x) self y + | Pair (x, y) -> + sub_release (sub_release failures self x) self y + | App (x, y) -> + sub_release (sub_release failures self x) self y + | Join ({ child; intermediate } as t) -> + let failures = sub_release failures self child in + begin match intermediate with + | None -> failures + | Some child' -> + t.intermediate <- None; + sub_release failures self child' + end + | Var _ -> failures + | Fix {doc; wrt} -> + sub_release (sub_release failures self wrt) self doc + | Prim t -> + begin match value with + | Eval_none | Eval_progress -> failures + | Eval_some x -> + begin match t.release (inj self) x with + | () -> failures + | exception exn -> + let bt = Printexc.get_raw_backtrace () in + (exn, bt) :: failures + end + end + end + | _ -> failures + +(* [sub_acquire] cannot raise *) +let rec sub_acquire : type a b . a t_ -> b t_ -> unit = fun origin -> + function + | Root _ -> assert false + | Pure _ -> () + | Operator t as self -> + (* [acquire] is true if this is the first time this operator + is used, in which case we need to acquire its children *) + let acquire = match t.trace with T0 -> true | _ -> false in + let trace = match t.trace with + | T0 -> T1 origin + | T1 x -> T2 (origin, x) + | T2 (x, y) -> T3 (origin, x, y) + | T3 (x, y, z) -> T4 (origin, x, y, z) + | T4 (x, y, z, w) -> + let obj_origin = obj_t origin in + let entries = + [| obj_t x; obj_t y; obj_t z; obj_t w; obj_origin; dummy; dummy; dummy |] + in + for i = 0 to 4 do add_idx self i entries.(i) done; + Tn { active = 5; count = 5; entries } + | Tn tn as trace -> + let index = tn.count in + let entries, trace = + (* possibly resize array [entries] *) + if index < Array.length tn.entries then ( + tn.count <- tn.count + 1; + (tn.entries, trace) + ) else ( + let entries = Array.make (index * 2) dummy in + Array.blit tn.entries 0 entries 0 index; + (entries, Tn { active = tn.active; count = index + 1; entries }) + ) + in + let obj_origin = obj_t origin in + entries.(index) <- obj_origin; + add_idx self index obj_origin; + trace + in + t.trace <- trace; + if acquire then ( + (* acquire immediate children, and so on recursively *) + match t.desc with + | Map (x, _) -> sub_acquire self x + | Map2 (x, y, _) -> + sub_acquire self x; + sub_acquire self y + | Pair (x, y) -> + sub_acquire self x; + sub_acquire self y + | App (x, y) -> + sub_acquire self x; + sub_acquire self y + | Fix {doc; wrt} -> + sub_acquire self doc; + sub_acquire self wrt + | Join { child; intermediate } -> + sub_acquire self child; + begin match intermediate with + | None -> () + | Some _ -> + assert false (* this can't initialized already, first-time acquire *) + end + | Var _ -> () + | Prim _ -> () + ) + +(* make sure that [origin] is in [self.trace], passed as last arg. *) +let activate_tracing self origin = function + | Tn tn -> + let idx = get_idx self origin in (* index of [self] in [origin.trace_idx] *) + let active = tn.active in + (* [idx < active] means [self] is already traced by [origin]. + We only have to add [self] to the entries if [idx >= active]. *) + if idx >= active then ( + tn.active <- active + 1; + ); + if idx > active then ( + (* swap with last entry in [tn.entries] *) + let old = tn.entries.(active) in + tn.entries.(idx) <- old; + tn.entries.(active) <- obj_t origin; + mov_idx self active idx old; + mov_idx self idx active origin + ) + | _ -> () + +let sub_is_damaged = function + | Root _ -> assert false + | Pure _ -> false + | Operator {value; _} -> + match value with + | Eval_none -> true + | Eval_some _ -> false + | Eval_progress -> assert false + +(* [sub_sample origin self] computes a value for [self]. + + [sub_sample] raise if any user-provided computation raises. + Graph will be left in a coherent state but exception will be propagated + to the observer. *) +let sub_sample queue = + let rec aux : type a b . a t_ -> b t_ -> b = fun origin -> + function + | Root _ -> assert false + | Pure x -> x + | Operator t as self -> + (* try to use cached value, if present *) + match t.value with + | Eval_some value -> + activate_tracing self origin t.trace; + value + | _ -> + t.value <- Eval_progress; + let result : b = match t.desc with + | Map (x, f) -> f (aux self x) + | Map2 (x, y, f) -> f (aux self x) (aux self y) + | Pair (x, y) -> (aux self x, aux self y) + | App (f, x) -> (aux self f) (aux self x) + | Fix {doc; wrt} -> + let _ = aux self wrt in + let result = aux self doc in + if sub_is_damaged wrt then + aux origin self + else ( + if sub_is_damaged doc then + do_invalidate Fragile self; + result + ) + | Join x -> + let intermediate = + (* We haven't touched any state yet, + it is safe for [aux] to raise *) + aux self x.child + in + begin match x.intermediate with + | None -> + x.intermediate <- Some intermediate; + sub_acquire self intermediate; + | Some x' when x' != intermediate -> + queue := Release_more { + origin = self; + element = x'; + next = !queue; + }; + x.intermediate <- Some intermediate; + sub_acquire self intermediate; + | Some _ -> () + end; + aux self intermediate + | Var x -> x.binding + | Prim t -> t.acquire (inj self) + in + begin match t.value with + | Eval_progress -> t.value <- Eval_some result; + | Eval_none | Eval_some _ -> () + end; + (* [self] just became active, so it may invalidate [origin] in case its + value changes because of [t.desc], like if it's a variable and gets + mutated, or if it's a primitive that gets invalidated. + We need to put [origin] into [self.trace] in case it isn't there yet. *) + activate_tracing self origin t.trace; + result + in + aux + +type 'a root = 'a t + +let observe ?(on_invalidate=ignore) child : _ root = + let root = Root { + child = prj child; + value = Eval_none; + on_invalidate; + trace_idx = I0; + acquired = false; + } in + inj root + +exception Release_failure of exn option * release_failure list + +let raw_flush_release_queue queue = + let rec aux failures = function + | Release_done -> failures + | Release_more t -> + let failures = sub_release failures t.origin t.element in + aux failures t.next + in + aux [] queue + +let flush_release_queue queue = + let queue' = !queue in + queue := Release_done; + raw_flush_release_queue queue' + +let sample queue x = match prj x with + | Pure _ | Operator _ -> assert false + | Root t as self -> + match t.value with + | Eval_some value -> value + | _ -> + (* no cached value, compute it now *) + if not t.acquired then ( + t.acquired <- true; + sub_acquire self t.child; + ); + t.value <- Eval_progress; + let value = sub_sample queue self t.child in + begin match t.value with + | Eval_progress -> t.value <- Eval_some value; (* cache value *) + | Eval_none | Eval_some _ -> () + end; + value + +let is_damaged x = match prj x with + | Pure _ | Operator _ -> assert false + | Root {value = Eval_some _; _} -> false + | Root {value = Eval_none | Eval_progress; _} -> true + +let release queue x = match prj x with + | Pure _ | Operator _ -> assert false + | Root t as self -> + if t.acquired then ( + (* release subtree, remove cached value *) + t.value <- Eval_none; + t.acquired <- false; + queue := Release_more { origin = self; element = t.child; next = !queue } + ) + +let set_on_invalidate x f = + match prj x with + | Pure _ | Operator _ -> assert false + | Root t -> t.on_invalidate <- f + +let flush_or_fail main_exn queue = + match flush_release_queue queue with + | [] -> () + | failures -> raise (Release_failure (main_exn, failures)) + +let quick_sample root = + let queue = ref Release_done in + match sample queue root with + | result -> flush_or_fail None queue; result + | exception exn -> flush_or_fail (Some exn) queue; raise exn + +let quick_release root = + let queue = ref Release_done in + release queue root; + flush_or_fail None queue + +module Infix = struct + let (>>=) x f = bind x ~f + let (>|=) x f = map x ~f + let (<*>) = app +end + +(*$R + let x = var 0 in + let y = map ~f:succ (get x) in + let o_y = Lwd.observe y in + assert_equal 1 (quick_sample o_y); + set x 10; + assert_equal 11 (quick_sample o_y); + *) diff --git a/vendor/lwd/lwd/lwd.mli b/vendor/lwd/lwd/lwd.mli new file mode 100644 index 00000000000..386dde33585 --- /dev/null +++ b/vendor/lwd/lwd/lwd.mli @@ -0,0 +1,146 @@ +type +'a t +(** A dynamic document of type ['a]. Documents can be produced in several + different ways: + + - operators, such as {!map}, {!bind}, {!app}, {!pair}, etc. + combine several documents into one. The result is (lazily) + updated whenever the sub-documents are. + + - variables {!var}, a mutable reference. + - primitive documents {!prim}, providing custom leaves to trees of + documents. +*) + +val return : 'a -> 'a t +(** The content document with the given value inside *) + +val pure : 'a -> 'a t +(** Alias to {!return} *) + +val map : 'a t -> f:('a -> 'b) -> 'b t +(** [map d ~f] is the document that has value [f x] whenever [d] has value [x] *) + +val map2 : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t +(** [map2 d1 d2 ~f] is the document that has value [f x1 x2] whenever + [d1] has value [x1] and [d2] has value [x2] *) + +val join : 'a t t -> 'a t +(** Monadic operator [join d] is the document pointed to by document [d]. + This is powerful but potentially costly in case of recomputation. +*) + +val bind : 'a t -> f:('a -> 'b t) -> 'b t +(** Monadic bind, a mix of {!join} and {!map} *) + +val app : ('a -> 'b) t -> 'a t -> 'b t +(** Applicative: [app df dx] is the document that has value [f x] + whenever [df] has value [f] and [dx] has value [x] *) + +val pair : 'a t -> 'b t -> ('a * 'b) t +(** [pair a b] is [map2 (fun x y->x,y) a b] *) + +val is_pure : 'a t -> 'a option +(** [is_pure x] will return [Some v] if [x] was built with [pure v] or + [return v]. + + Normal code should not rely on the "reactive-ness" of a value, but this is + often useful for optimising reactive data structures. +*) + +type 'a var +(** The workhorse of Lwd: a mutable variable that also tracks dependencies. + Every time {!set} is called, all documents that depend on this variable + via {!map}, {!bind}, etc. will be at least partially invalidated + and will be recomputed incrementally on demand. *) + +val var : 'a -> 'a var +(** Create a new variable with the given initial value *) + +val get : 'a var -> 'a t +(** A document that reflects the current content of a variable *) + +val set : 'a var -> 'a -> unit +(** Change the variable's content, invalidating all documents depending + on it. *) + +val peek : 'a var -> 'a +(** Observe the current value of the variable, without any dependency + tracking. *) + +type +'a prim +(** A primitive document. It can correspond, for example, to + a primitive UI element. + + A primitive is a resource with [acquire] and [release] functions + to manage its lifecycle. *) + +val prim : acquire:('a prim -> 'a) -> release:('a prim -> 'a -> unit) -> 'a prim +(** create a new primitive document. + @param acquire is called when the document becomes observed (indirectly) + via at least one {!root}. The resulting primitive is passed as an argument + to support certain recursive use cases. + @param release is called when the document is no longer observed. + Internal resources can be freed. *) + +val get_prim : 'a prim -> 'a t +val invalidate : 'a prim -> unit + +(** Some document might change variables during their evaluation. + These are called "unstable" documents. + + Evaluating these might need many passes to eventually converge to a value. + The `fix` operator tries to stabilize a sub-document by repeating + evaluation until a stable condition is reached. +*) +val fix : 'a t -> wrt:_ t -> 'a t + +val default_unsafe_mutation_logger : unit -> unit +val unsafe_mutation_logger : (unit -> unit) ref + +(** Releasing unused graphs *) +type release_failure = exn * Printexc.raw_backtrace + +exception Release_failure of exn option * release_failure list + +type release_queue +val make_release_queue : unit -> release_queue +val flush_release_queue : release_queue -> release_failure list + +type +'a root +(** A root of computation, whose value(s) over time we're interested in. *) + +val observe : ?on_invalidate:('a -> unit) -> 'a t -> 'a root +(** [observe x] creates a root that contains document [x]. + @param on_invalidate is called whenever the root is invalidated + because the content of [x] has changed. This can be useful to + perform side-effects such as re-rendering some UI. *) + +val set_on_invalidate : 'a root -> ('a -> unit) -> unit +(** Change the callback for the root. + See [observe] for more details. *) + +val sample : release_queue -> 'a root -> 'a +(** Force the computation of the value for this root. + The value is cached, so this is idempotent, until the next invalidation. *) + +val is_damaged : 'a root -> bool +(** [is_damaged root] is true if the root doesn't have a valid value in + cache. This can be the case if the value was never computed, or + if it was computed and then invalidated. *) + +val release : release_queue -> 'a root -> unit +(** Forget about this root and release sub-values no longer reachable from + any root. *) + +val quick_sample : 'a root -> 'a + +val quick_release : 'a root -> unit + +module Infix : sig + val (>|=) : 'a t -> ('a -> 'b) -> 'b t + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t + val (<*>) : ('a -> 'b) t -> 'a t -> 'b t +end + +(* For debug purposes *) +val dump_trace : 'a t -> unit diff --git a/vendor/lwd/lwd/lwd_utils.ml b/vendor/lwd/lwd/lwd_utils.ml new file mode 100644 index 00000000000..e46382eab83 --- /dev/null +++ b/vendor/lwd/lwd/lwd_utils.ml @@ -0,0 +1,76 @@ + +type 'a monoid = 'a * ('a -> 'a -> 'a) + +let lift_monoid (zero, plus) = + (Lwd.return zero, Lwd.map2 ~f:plus) + +let map_reduce inj (zero, plus) items = + let rec cons_monoid c xs v = + match xs with + | (c', v') :: xs when c = c' -> + cons_monoid (c + 1) xs (plus v' v) + | xs -> (c, v) :: xs + in + let cons_monoid xs v = cons_monoid 0 xs (inj v) in + match List.fold_left cons_monoid [] items with + | [] -> zero + | (_,x) :: xs -> + List.fold_left (fun acc (_, v) -> plus v acc) x xs + +let reduce monoid items = map_reduce (fun x -> x) monoid items + +let rec cons_lwd_monoid plus c xs v = + match xs with + | (c', v') :: xs when c = c' -> + cons_lwd_monoid plus (c + 1) xs (Lwd.map2 ~f:plus v' v) + | xs -> (c, v) :: xs + +let pack (zero, plus) items = + match List.fold_left (cons_lwd_monoid plus 0) [] items with + | [] -> Lwd.return zero + | (_,x) :: xs -> + List.fold_left (fun acc (_, v) -> Lwd.map2 ~f:plus v acc) x xs + +let pack_seq (zero, plus) items = + match Seq.fold_left (cons_lwd_monoid plus 0) [] items with + | [] -> Lwd.return zero + | (_,x) :: xs -> + List.fold_left (fun acc (_, v) -> Lwd.map2 ~f:plus v acc) x xs + +let rec map_l (f:'a -> 'b Lwd.t) (l:'a list) : 'b list Lwd.t = + match l with + | [] -> Lwd.return [] + | x :: tl -> Lwd.map2 ~f:List.cons (f x) (map_l f tl) + +let flatten_l (l:'a Lwd.t list) : 'a list Lwd.t = + map_l (fun x->x) l + +(** {1 Miscellaneous functions} + + I don't know where to put these, but they are useful, especially for + UI-related computations. +*) + +let mini a b : int = if b < a then b else a + +let maxi a b : int = if b > a then b else a + +let clampi x ~min ~max : int = + if x < min then + min + else if x > max then + max + else + x + +let minf a b : float = if b < a then b else a + +let maxf a b : float = if b > a then b else a + +let clampf x ~min ~max : float = + if x < min then + min + else if x > max then + max + else + x diff --git a/vendor/lwd/lwd/lwd_utils.mli b/vendor/lwd/lwd/lwd_utils.mli new file mode 100644 index 00000000000..8b1e50804ab --- /dev/null +++ b/vendor/lwd/lwd/lwd_utils.mli @@ -0,0 +1,62 @@ +type 'a monoid = 'a * ('a -> 'a -> 'a) +(** A monoid, defined by a default element and an associative operation *) + +val lift_monoid : 'a monoid -> 'a Lwd.t monoid +(** Use a monoid inside [Lwd] *) + +(** {1 List reduction functions} + + All reductions are balanced, relying on operator associativity. + + [fold_left] would compute a chain like: + [fold f [a; b; c; d] = f a (f b (f c d)] + + [reduce] uses tree-shaped computations like: + [reduce f [a; b; c; d] = f (f a b) (f c d)] + + The depth of the computation grows in O(log n) where n is the length of the + input sequence. +*) + +val pack : 'a monoid -> 'a Lwd.t list -> 'a Lwd.t +(** Reduce a list of elements in [Lwd] monad *) + +val pack_seq : 'a monoid -> 'a Lwd.t Seq.t -> 'a Lwd.t +(** Reduce an (OCaml) [Seq.t] with a monoid *) + +val reduce : 'a monoid -> 'a list -> 'a +(** Reduce a list with a monoid **) + +val map_reduce : ('a -> 'b) -> 'b monoid -> 'a list -> 'b +(** Map and reduce a list with a monoid **) + +(** {1 Other Lwd list functions} *) + +val map_l : ('a -> 'b Lwd.t) -> 'a list -> 'b list Lwd.t + +val flatten_l : 'a Lwd.t list -> 'a list Lwd.t +(** Commute [Lwd] and [list] *) + +(** {1 Miscellaneous functions} + + I don't know where to put these, but they are useful, especially for + UI-related computations. +*) + +val mini : int -> int -> int +(** Minimum of two integers *) + +val maxi : int -> int -> int +(** Maximum of two integers *) + +val clampi : int -> min:int -> max:int -> int +(** Clamp an integer between two bounds. *) + +val minf : float -> float -> float +(** Minimum of two floats *) + +val maxf : float -> float -> float +(** Maximum of two floats *) + +val clampf : float -> min:float -> max:float -> float +(** Clamp a float between two bounds. *) diff --git a/vendor/lwd/nottui/dune b/vendor/lwd/nottui/dune new file mode 100644 index 00000000000..e8e4162fa5a --- /dev/null +++ b/vendor/lwd/nottui/dune @@ -0,0 +1,4 @@ +(library + (name dune_nottui) + (wrapped false) + (libraries dune_lwd dune_notty dune_notty_unix)) diff --git a/vendor/lwd/nottui/nottui.ml b/vendor/lwd/nottui/nottui.ml new file mode 100644 index 00000000000..8c67a8e4e6d --- /dev/null +++ b/vendor/lwd/nottui/nottui.ml @@ -0,0 +1,872 @@ +open Notty +open Lwd_utils + +module Focus : +sig + type var = int Lwd.var + type handle + val make : unit -> handle + val request : handle -> unit + val request_var : var -> unit + val release : handle -> unit + + type status = + | Empty + | Handle of int * var + | Conflict of int + + val empty : status + (*val is_empty : status -> bool*) + val status : handle -> status Lwd.t + val has_focus : status -> bool + val merge : status -> status -> status +end = struct + + type var = int Lwd.var + + type status = + | Empty + | Handle of int * var + | Conflict of int + + type handle = var * status Lwd.t + + let make () = + let v = Lwd.var 0 in + (v, Lwd.map ~f:(fun i -> Handle (i, v)) (Lwd.get v)) + + let empty : status = Empty + + let status (h : handle) : status Lwd.t = snd h + + let has_focus = function + | Empty -> false + | Handle (i, _) | Conflict i -> i > 0 + + let clock = ref 0 + + let request_var (v : var) = + incr clock; + Lwd.set v !clock + + let request (v, _ : handle) = request_var v + let release (v, _ : handle) = incr clock; Lwd.set v 0 + + let merge s1 s2 : status = match s1, s2 with + | Empty, x | x, Empty -> x + | _, Handle (0, _) -> s1 + | Handle (0, _), _ -> s2 + | Handle (i1, _), Handle (i2, _) when i1 = i2 -> s1 + | (Handle (i1, _) | Conflict i1), Conflict i2 when i1 < i2 -> s2 + | (Handle (i1, _) | Conflict i1), Handle (i2, _) when i1 < i2 -> + Conflict i2 + | Conflict _, (Handle (_, _) | Conflict _) -> s1 + | Handle (i1, _), (Handle (_, _) | Conflict _) -> Conflict i1 +end + +module Gravity : +sig + type direction = [ + | `Negative + | `Neutral + | `Positive + ] + val pp_direction : Format.formatter -> direction -> unit + type t + val pp : Format.formatter -> t -> unit + val make : h:direction -> v:direction -> t + val default : t + val h : t -> direction + val v : t -> direction + + type t2 + val pair : t -> t -> t2 + val p1 : t2 -> t + val p2 : t2 -> t +end = +struct + type direction = [ `Negative | `Neutral | `Positive ] + type t = int + type t2 = int + + let default = 0 + + let pack = function + | `Negative -> 0 + | `Neutral -> 1 + | `Positive -> 2 + + let unpack = function + | 0 -> `Negative + | 1 -> `Neutral + | _ -> `Positive + + let make ~h ~v = + (pack h lsl 2) lor pack v + + let h x = unpack (x lsr 2) + let v x = unpack (x land 3) + + let pp_direction ppf dir = + let text = match dir with + | `Negative -> "`Negative" + | `Neutral -> "`Neutral" + | `Positive -> "`Positive" + in + Format.pp_print_string ppf text + + let pp ppf g = + Format.fprintf ppf "{ h = %a; v = %a }" pp_direction (h g) pp_direction (v g) + + let pair t1 t2 = + (t1 lsl 4) lor t2 + + let p1 t = (t lsr 4) land 15 + let p2 t = t land 15 +end +type gravity = Gravity.t + +module Interval : sig + type t = private int + val make : int -> int -> t + val shift : t -> int -> t + val fst : t -> int + val snd : t -> int + (*val size : t -> int*) + val zero : t +end = struct + type t = int + + let half = Sys.word_size lsr 1 + let mask = (1 lsl half) - 1 + + let make x y = + let size = y - x in + (*assert (size >= 0);*) + (x lsl half) lor (size land mask) + + let shift t d = + t + d lsl half + + let fst t = t asr half + let size t = t land mask + let snd t = fst t + size t + + let zero = 0 +end + +module Ui = +struct + type may_handle = [ `Unhandled | `Handled ] + + type mouse_handler = x:int -> y:int -> Unescape.button -> [ + | `Unhandled + | `Handled + | `Grab of (x:int -> y:int -> unit) * (x:int -> y:int -> unit) + ] + + type semantic_key = [ + (* Clipboard *) + | `Copy + | `Paste + (* Focus management *) + | `Focus of [`Next | `Prev | `Left | `Right | `Up | `Down] + ] + + type key = [ + | Unescape.special | `Uchar of Uchar.t | `ASCII of char | semantic_key + ] * Unescape.mods + + type mouse = Unescape.mouse + + type event = [ `Key of key | `Mouse of mouse | `Paste of Unescape.paste ] + + type layout_spec = { w : int; h : int; sw : int; sh : int } + + let pp_layout_spec ppf { w; h; sw; sh } = + Format.fprintf ppf "{ w = %d; h = %d; sw = %d; sh = %d }" w h sw sh + + type flags = int + let flags_none = 0 + let flag_transient_sensor = 1 + let flag_permanent_sensor = 2 + + type size_sensor = w:int -> h:int -> unit + type frame_sensor = x:int -> y:int -> w:int -> h:int -> unit -> unit + + type t = { + w : int; sw : int; + h : int; sh : int; + mutable desc : desc; + focus : Focus.status; + mutable flags : flags; + mutable sensor_cache : (int * int * int * int) option; + mutable cache : cache; + } + and cache = { + vx : Interval.t; vy : Interval.t; + image : image; + } + and desc = + | Atom of image + | Size_sensor of t * size_sensor + | Transient_sensor of t * frame_sensor + | Permanent_sensor of t * frame_sensor + | Resize of t * Gravity.t2 * A.t + | Mouse_handler of t * mouse_handler + | Focus_area of t * (key -> may_handle) + | Shift_area of t * int * int + | Event_filter of t * ([`Key of key | `Mouse of mouse] -> may_handle) + | X of t * t + | Y of t * t + | Z of t * t + + + let layout_spec t : layout_spec = + { w = t.w; h = t.h; sw = t.sw; sh = t.sh } + let layout_width t = t.w + let layout_stretch_width t = t.sw + let layout_height t = t.h + let layout_stretch_height t = t.sh + + let cache : cache = + { vx = Interval.zero; vy = Interval.zero; image = I.empty } + + let empty : t = + { w = 0; sw = 0; h = 0; sh = 0; flags = flags_none; + focus = Focus.empty; desc = Atom I.empty; + sensor_cache = None; cache } + + let atom img : t = + { w = I.width img; sw = 0; + h = I.height img; sh = 0; + focus = Focus.empty; flags = flags_none; + desc = Atom img; + sensor_cache = None; cache; } + + let space_1_0 = atom (I.void 1 0) + let space_0_1 = atom (I.void 0 1) + let space_1_1 = atom (I.void 1 1) + + let space x y = + match x, y with + | 0, 0 -> empty + | 1, 0 -> space_1_0 + | 0, 1 -> space_0_1 + | 1, 1 -> space_1_1 + | _ -> atom (I.void x y) + + let mouse_area f t : t = + { t with desc = Mouse_handler (t, f) } + + let keyboard_area ?focus f t : t = + let focus = match focus with + | None -> t.focus + | Some focus -> Focus.merge focus t.focus + in + { t with desc = Focus_area (t, f); focus } + + let shift_area x y t : t = + { t with desc = Shift_area (t, x, y) } + + let size_sensor handler t : t = + { t with desc = Size_sensor (t, handler) } + + let transient_sensor frame_sensor t = + { t with desc = Transient_sensor (t, frame_sensor); + flags = t.flags lor flag_transient_sensor } + + let permanent_sensor frame_sensor t = + { t with desc = Permanent_sensor (t, frame_sensor); + flags = t.flags lor flag_permanent_sensor } + + let prepare_gravity = function + | None, None -> Gravity.(pair default default) + | Some g, None | None, Some g -> Gravity.(pair g g) + | Some pad, Some crop -> Gravity.(pair pad crop) + + let resize ?w ?h ?sw ?sh ?pad ?crop ?(bg=A.empty) t : t = + let g = prepare_gravity (pad, crop) in + match (w, t.w), (h, t.h), (sw, t.sw), (sh, t.sh) with + | (Some w, _ | None, w), (Some h, _ | None, h), + (Some sw, _ | None, sw), (Some sh, _ | None, sh) -> + {t with w; h; sw; sh; desc = Resize (t, g, bg)} + + let resize_to ({w; h; sw; sh} : layout_spec) ?pad ?crop ?(bg=A.empty) t : t = + let g = prepare_gravity (pad, crop) in + {t with w; h; sw; sh; desc = Resize (t, g, bg)} + + let event_filter ?focus f t : t = + let focus = match focus with + | None -> t.focus + | Some focus -> focus + in + { t with desc = Event_filter (t, f); focus } + + let join_x a b = { + w = (a.w + b.w); sw = (a.sw + b.sw); + h = (maxi a.h b.h); sh = (maxi a.sh b.sh); + flags = a.flags lor b.flags; + focus = Focus.merge a.focus b.focus; desc = X (a, b); + sensor_cache = None; cache + } + + let join_y a b = { + w = (maxi a.w b.w); sw = (maxi a.sw b.sw); + h = (a.h + b.h); sh = (a.sh + b.sh); + flags = a.flags lor b.flags; + focus = Focus.merge a.focus b.focus; desc = Y (a, b); + sensor_cache = None; cache; + } + + let join_z a b = { + w = (maxi a.w b.w); sw = (maxi a.sw b.sw); + h = (maxi a.h b.h); sh = (maxi a.sh b.sh); + flags = a.flags lor b.flags; + focus = Focus.merge a.focus b.focus; desc = Z (a, b); + sensor_cache = None; cache; + } + + let pack_x = (empty, join_x) + let pack_y = (empty, join_y) + let pack_z = (empty, join_z) + + let hcat xs = Lwd_utils.reduce pack_x xs + let vcat xs = Lwd_utils.reduce pack_y xs + let zcat xs = Lwd_utils.reduce pack_z xs + + let has_focus t = Focus.has_focus t.focus + + let rec pp ppf t = + Format.fprintf ppf + "@[{@ w = %d;@ h = %d;@ sw = %d;@ sh = %d;@ desc = @[%a@];@ }@]" + t.w t.h t.sw t.sh pp_desc t.desc + + and pp_desc ppf = function + | Atom _ -> Format.fprintf ppf "Atom _" + | Size_sensor (desc, _) -> + Format.fprintf ppf "Size_sensor (@[%a,@ _@])" pp desc + | Transient_sensor (desc, _) -> + Format.fprintf ppf "Transient_sensor (@[%a,@ _@])" pp desc + | Permanent_sensor (desc, _) -> + Format.fprintf ppf "Permanent_sensor (@[%a,@ _@])" pp desc + | Resize (desc, gravity, _bg) -> + Format.fprintf ppf "Resize (@[%a,@ %a,@ %a@])" pp desc + Gravity.pp (Gravity.p1 gravity) + Gravity.pp (Gravity.p2 gravity) + | Mouse_handler (n, _) -> + Format.fprintf ppf "Mouse_handler (@[%a,@ _@])" pp n + | Focus_area (n, _) -> + Format.fprintf ppf "Focus_area (@[%a,@ _@])" pp n + | Shift_area (n, _, _) -> + Format.fprintf ppf "Shift_area (@[%a,@ _@])" pp n + | Event_filter (n, _) -> + Format.fprintf ppf "Event_filter (@[%a,@ _@])" pp n + | X (a, b) -> Format.fprintf ppf "X (@[%a,@ %a@])" pp a pp b + | Y (a, b) -> Format.fprintf ppf "Y (@[%a,@ %a@])" pp a pp b + | Z (a, b) -> Format.fprintf ppf "Z (@[%a,@ %a@])" pp a pp b + + let iter f ui = match ui.desc with + | Atom _ -> () + | Size_sensor (u, _) | Transient_sensor (u, _) | Permanent_sensor (u, _) + | Resize (u, _, _) | Mouse_handler (u, _) + | Focus_area (u, _) | Shift_area (u, _, _) | Event_filter (u, _) + -> f u + | X (u1, u2) | Y (u1, u2) | Z (u1, u2) -> f u1; f u2 +end +type ui = Ui.t + +module Renderer = +struct + open Ui + + type size = int * int + + type grab_function = (x:int -> y:int -> unit) * (x:int -> y:int -> unit) + type t = { + mutable size : size; + mutable view : ui; + mutable mouse_grab : grab_function option; + } + + let make () = { + mouse_grab = None; + size = (0, 0); + view = Ui.empty; + } + + let size t = t.size + + let solve_focus ui i = + let rec aux ui = + match ui.focus with + | Focus.Empty | Focus.Handle (0, _) -> () + | Focus.Handle (i', _) when i = i' -> () + | Focus.Handle (_, v) -> Lwd.set v 0 + | Focus.Conflict _ -> Ui.iter aux ui + in + aux ui + + let split ~a ~sa ~b ~sb total = + let stretch = sa + sb in + let flex = total - a - b in + if stretch > 0 && flex > 0 then + let ratio = + if sa > sb then + flex * sa / stretch + else + flex - flex * sb / stretch + in + (a + ratio, b + flex - ratio) + else + (a, b) + + let pack ~fixed ~stretch total g1 g2 = + let flex = total - fixed in + if stretch > 0 && flex > 0 then + (0, total) + else + let gravity = if flex >= 0 then g1 else g2 in + match gravity with + | `Negative -> (0, fixed) + | `Neutral -> (flex / 2, fixed) + | `Positive -> (flex, fixed) + + let has_transient_sensor flags = flags land flag_transient_sensor <> 0 + let has_permanent_sensor flags = flags land flag_permanent_sensor <> 0 + + let rec update_sensors ox oy sw sh ui = + if has_transient_sensor ui.flags || ( + has_permanent_sensor ui.flags && + match ui.sensor_cache with + | None -> true + | Some (ox', oy', sw', sh') -> + not (ox = ox' && oy = oy' && sw = sw' && sh = sh') + ) + then ( + ui.flags <- ui.flags land lnot flag_transient_sensor; + if has_permanent_sensor ui.flags then + ui.sensor_cache <- Some (ox, oy, sw, sh); + match ui.desc with + | Atom _ -> () + | Size_sensor (t, _) | Mouse_handler (t, _) + | Focus_area (t, _) | Event_filter (t, _) -> + update_sensors ox oy sw sh t + | Transient_sensor (t, sensor) -> + ui.desc <- t.desc; + let sensor = sensor ~x:ox ~y:oy ~w:sw ~h:sh in + update_sensors ox oy sw sh t; + sensor () + | Permanent_sensor (t, sensor) -> + let sensor = sensor ~x:ox ~y:oy ~w:sw ~h:sh in + update_sensors ox oy sw sh t; + sensor () + | Resize (t, g, _) -> + let open Gravity in + let dx, rw = pack ~fixed:t.w ~stretch:t.sw sw (h (p1 g)) (h (p2 g)) in + let dy, rh = pack ~fixed:t.h ~stretch:t.sh sh (v (p1 g)) (v (p2 g)) in + update_sensors (ox + dx) (oy + dy) rw rh t + | Shift_area (t, sx, sy) -> + update_sensors (ox - sx) (oy - sy) sw sh t + | X (a, b) -> + let aw, bw = split ~a:a.w ~sa:a.sw ~b:b.w ~sb:b.sw sw in + update_sensors ox oy aw sh a; + update_sensors (ox + aw) oy bw sh b + | Y (a, b) -> + let ah, bh = split ~a:a.h ~sa:a.sh ~b:b.h ~sb:b.sh sh in + update_sensors ox oy sw ah a; + update_sensors ox (oy + ah) sw bh b + | Z (a, b) -> + update_sensors ox oy sw sh a; + update_sensors ox oy sw sh b + ) + + let update_focus ui = + match ui.focus with + | Focus.Empty | Focus.Handle _ -> () + | Focus.Conflict i -> solve_focus ui i + + let update t size ui = + t.size <- size; + t.view <- ui; + update_sensors 0 0 (fst size) (snd size) ui; + update_focus ui + + let dispatch_mouse st x y btn w h t = + let handle ox oy f = + match f ~x:(x - ox) ~y:(y - oy) btn with + | `Unhandled -> false + | `Handled -> true + | `Grab f -> st.mouse_grab <- Some f; true + in + let rec aux ox oy sw sh t = + match t.desc with + | Atom _ -> false + | X (a, b) -> + let aw, bw = split ~a:a.w ~sa:a.sw ~b:b.w ~sb:b.sw sw in + if x - ox < aw + then aux ox oy aw sh a + else aux (ox + aw) oy bw sh b + | Y (a, b) -> + let ah, bh = split ~a:a.h ~sa:a.sh ~b:b.h ~sb:b.sh sh in + if y - oy < ah + then aux ox oy sw ah a + else aux ox (oy + ah) sw bh b + | Z (a, b) -> + aux ox oy sw sh b || aux ox oy sw sh a + | Mouse_handler (t, f) -> + let _offsetx, rw = pack ~fixed:t.w ~stretch:t.sw sw `Negative `Negative + and _offsety, rh = pack ~fixed:t.h ~stretch:t.sh sh `Negative `Negative + in + assert (_offsetx = 0 && _offsety = 0); + (x - ox >= 0 && x - ox <= rw && y - oy >= 0 && y - oy <= rh) && + (aux ox oy sw sh t || handle ox oy f) + | Size_sensor (desc, _) + | Transient_sensor (desc, _) | Permanent_sensor (desc, _) + | Focus_area (desc, _) -> + aux ox oy sw sh desc + | Shift_area (desc, sx, sy) -> + aux (ox - sx) (oy - sy) sw sh desc + | Resize (t, g, _bg) -> + let open Gravity in + let dx, rw = pack ~fixed:t.w ~stretch:t.sw sw (h (p1 g)) (h (p2 g)) in + let dy, rh = pack ~fixed:t.h ~stretch:t.sh sh (v (p1 g)) (v (p2 g)) in + aux (ox + dx) (oy + dy) rw rh t + | Event_filter (n, f) -> + begin match f (`Mouse (`Press btn, (x, y), [])) with + | `Handled -> true + | `Unhandled -> aux ox oy sw sh n + end + in + aux 0 0 w h t + + let release_grab st x y = + match st.mouse_grab with + | None -> () + | Some (_, release) -> + st.mouse_grab <- None; + release ~x ~y + + let dispatch_mouse t (event, (x, y), _mods) = + if + match event with + | `Press btn -> + release_grab t x y; + let w, h = t.size in + dispatch_mouse t x y btn w h t.view + | `Drag -> + begin match t.mouse_grab with + | None -> false + | Some (drag, _) -> drag ~x ~y; true + end + | `Release -> + release_grab t x y; true + then `Handled + else `Unhandled + + let resize_canvas rw rh image = + let w = I.width image in + let h = I.height image in + if w <> rw || h <> rh + then I.pad ~r:(rw - w) ~b:(rh - h) image + else image + + let resize_canvas2 ox oy rw rh image = + let w = I.width image in + let h = I.height image in + I.pad ~l:ox ~t:oy ~r:(rw - w - ox) ~b:(rh - h - oy) image + + let same_size w h image = + w = I.width image && + h = I.height image + + let rec render_node vx1 vy1 vx2 vy2 sw sh t : cache = + if + let cache = t.cache in + vx1 >= Interval.fst cache.vx && vy1 >= Interval.fst cache.vy && + vx2 <= Interval.snd cache.vx && vy2 <= Interval.snd cache.vy && + same_size sw sh cache.image + then t.cache + else if vx2 < 0 || vy2 < 0 || sw < vx1 || sh < vy1 then + let vx = Interval.make vx1 vx2 and vy = Interval.make vy1 vy2 in + { vx; vy; image = I.void sw sh } + else + let cache = match t.desc with + | Atom image -> + { vx = Interval.make 0 sw; + vy = Interval.make 0 sh; + image = resize_canvas sw sh image } + | Size_sensor (desc, handler) -> + handler ~w:sw ~h:sh; + render_node vx1 vy1 vx2 vy2 sw sh desc + | Transient_sensor (desc, _) | Permanent_sensor (desc, _) -> + render_node vx1 vy1 vx2 vy2 sw sh desc + | Focus_area (desc, _) | Mouse_handler (desc, _) -> + render_node vx1 vy1 vx2 vy2 sw sh desc + | Shift_area (t', sx, sy) -> + let cache = render_node + (vx1 + sx) (vy1 + sy) (vx2 + sx) (vy2 + sy) (sx + sw) (sy + sh) t' + in + let vx = Interval.make vx1 vx2 and vy = Interval.make vy1 vy2 in + let image = resize_canvas sw sh (I.crop ~l:sx ~t:sy cache.image) in + { vx; vy; image } + | X (a, b) -> + let aw, bw = split ~a:a.w ~sa:a.sw ~b:b.w ~sb:b.sw sw in + let ca = render_node vx1 vy1 vx2 vy2 aw sh a in + let cb = render_node (vx1 - aw) vy1 (vx2 - aw) vy2 bw sh b in + let vx = Interval.make + (maxi (Interval.fst ca.vx) (Interval.fst cb.vx + aw)) + (mini (Interval.snd ca.vx) (Interval.snd cb.vx + aw)) + and vy = Interval.make + (maxi (Interval.fst ca.vy) (Interval.fst cb.vy)) + (mini (Interval.snd ca.vy) (Interval.snd cb.vy)) + and image = resize_canvas sw sh (I.(<|>) ca.image cb.image) in + { vx; vy; image } + | Y (a, b) -> + let ah, bh = split ~a:a.h ~sa:a.sh ~b:b.h ~sb:b.sh sh in + let ca = render_node vx1 vy1 vx2 vy2 sw ah a in + let cb = render_node vx1 (vy1 - ah) vx2 (vy2 - ah) sw bh b in + let vx = Interval.make + (maxi (Interval.fst ca.vx) (Interval.fst cb.vx)) + (mini (Interval.snd ca.vx) (Interval.snd cb.vx)) + and vy = Interval.make + (maxi (Interval.fst ca.vy) (Interval.fst cb.vy + ah)) + (mini (Interval.snd ca.vy) (Interval.snd cb.vy + ah)) + and image = resize_canvas sw sh (I.(<->) ca.image cb.image) in + { vx; vy; image } + | Z (a, b) -> + let ca = render_node vx1 vy1 vx2 vy2 sw sh a in + let cb = render_node vx1 vy1 vx2 vy2 sw sh b in + let vx = Interval.make + (maxi (Interval.fst ca.vx) (Interval.fst cb.vx)) + (mini (Interval.snd ca.vx) (Interval.snd cb.vx)) + and vy = Interval.make + (maxi (Interval.fst ca.vy) (Interval.fst cb.vy)) + (mini (Interval.snd ca.vy) (Interval.snd cb.vy)) + and image = resize_canvas sw sh (I.() cb.image ca.image) in + { vx; vy; image } + | Resize (t, g, bg) -> + let open Gravity in + let dx, rw = pack ~fixed:t.w ~stretch:t.sw sw (h (p1 g)) (h (p2 g)) in + let dy, rh = pack ~fixed:t.h ~stretch:t.sh sh (v (p1 g)) (v (p2 g)) in + let c = + render_node (vx1 - dx) (vy1 - dy) (vx2 - dx) (vy2 - dy) rw rh t + in + let image = resize_canvas2 dx dy sw sh c.image in + let image = + if bg != A.empty then + I.(image char bg ' ' sw sh) + else + image + in + let vx = Interval.shift c.vx dx in + let vy = Interval.shift c.vy dy in + { vx; vy; image } + | Event_filter (t, _f) -> + render_node vx1 vy1 vx2 vy2 sw sh t + in + t.cache <- cache; + cache + + let image {size = (w, h); view; _} = + (render_node 0 0 w h w h view).image + + let dispatch_raw_key st key = + let rec iter (st: ui list) : [> `Unhandled] = + match st with + | [] -> `Unhandled + | ui :: tl -> + begin match ui.desc with + | Atom _ -> iter tl + | X (a, b) | Y (a, b) | Z (a, b) -> + (* Try left/top most branch first *) + let st' = + if Focus.has_focus b.focus + then b :: tl + else a :: b :: tl + in + iter st' + | Focus_area (t, f) -> + begin match iter [t] with + | `Handled -> `Handled + | `Unhandled -> + match f key with + | `Handled -> `Handled + | `Unhandled -> iter tl + end + | Mouse_handler (t, _) | Size_sensor (t, _) + | Transient_sensor (t, _) | Permanent_sensor (t, _) + | Shift_area (t, _, _) | Resize (t, _, _) -> + iter (t :: tl) + | Event_filter (t, f) -> + begin match f (`Key key) with + | `Unhandled -> iter (t :: tl) + | `Handled -> `Handled + end + end + in + iter [st.view] + + exception Acquired_focus + + let grab_focus ui = + let rec aux ui = + match ui.focus with + | Focus.Empty -> () + | Focus.Handle (_, v) -> Focus.request_var v; raise Acquired_focus + | Focus.Conflict _ -> iter aux ui + in + try aux ui; false with Acquired_focus -> true + + let rec dispatch_focus t dir = + match t.desc with + | Atom _ -> false + | Mouse_handler (t, _) | Size_sensor (t, _) + | Transient_sensor (t, _) | Permanent_sensor (t, _) + | Shift_area (t, _, _) | Resize (t, _, _) | Event_filter (t, _) -> + dispatch_focus t dir + | Focus_area (t', _) -> + if Focus.has_focus t'.focus then + dispatch_focus t' dir || grab_focus t + else if Focus.has_focus t.focus then + false + else + grab_focus t + | X (a, b) -> + begin if Focus.has_focus a.focus then + dispatch_focus a dir || + (match dir with + | `Next | `Right -> dispatch_focus b dir + | _ -> false + ) + else if Focus.has_focus b.focus then + dispatch_focus b dir || + (match dir with + | `Prev | `Left -> dispatch_focus a dir + | _ -> false + ) + else + match dir with + | `Prev | `Left | `Up -> dispatch_focus b dir || dispatch_focus a dir + | `Next | `Down | `Right -> dispatch_focus a dir || dispatch_focus b dir + end + | Y (a, b) -> + begin if Focus.has_focus a.focus then + dispatch_focus a dir || + (match dir with + | `Next | `Down -> dispatch_focus b dir + | _ -> false + ) + else if Focus.has_focus b.focus then + dispatch_focus b dir || + (match dir with + | `Prev | `Up -> dispatch_focus a dir + | _ -> false + ) + else match dir with + | `Prev | `Up -> dispatch_focus b dir || dispatch_focus a dir + | `Next | `Left | `Down | `Right -> dispatch_focus a dir || dispatch_focus b dir + end + | Z (a, b) -> + if Focus.has_focus a.focus then + dispatch_focus a dir + else + dispatch_focus b dir || dispatch_focus a dir + + let rec dispatch_key st key = + match dispatch_raw_key st key, key with + | `Handled, _ -> `Handled + | `Unhandled, (`Arrow dir, [`Meta]) -> + let dir : [`Down | `Left | `Right | `Up] :> + [`Down | `Left | `Right | `Up | `Next | `Prev] = dir in + dispatch_key st (`Focus dir, [`Meta]) + | `Unhandled, (`Tab, mods) -> + let dir = if List.mem `Shift mods then `Prev else `Next in + dispatch_key st (`Focus dir, mods) + | `Unhandled, (`Focus dir, _) -> + if dispatch_focus st.view dir then `Handled else `Unhandled + | `Unhandled, _ -> `Unhandled + + let dispatch_event t = function + | `Key key -> dispatch_key t key + | `Mouse mouse -> dispatch_mouse t mouse + | `Paste _ -> `Unhandled +end + +module Ui_loop = +struct + open Notty_unix + + (* FIXME Uses of [quick_sample] and [quick_release] should be replaced by + [sample] and [release] with the appropriate release management. *) + + let step ?(process_event=true) ?(timeout=(-1.0)) ~renderer term root = + let size = Term.size term in + let image = + let rec stabilize () = + let tree = Lwd.quick_sample root in + Renderer.update renderer size tree; + let image = Renderer.image renderer in + if Lwd.is_damaged root + then stabilize () + else image + in + stabilize () + in + Term.image term image; + if process_event then + let i, _ = Term.fds term in + let has_event = + let rec select () = + match Unix.select [i] [] [i] timeout with + | [], [], [] -> false + | _ -> true + | exception (Unix.Unix_error (Unix.EINTR, _, _)) -> select () + in + select () + in + if has_event then + match Term.event term with + | `End -> () + | `Resize _ -> () + | #Unescape.event as event -> + let event = (event : Unescape.event :> Ui.event) in + ignore (Renderer.dispatch_event renderer event : [`Handled | `Unhandled]) + + let run_with_term term ?tick_period ?(tick=ignore) ~renderer quit t = + let quit = Lwd.observe (Lwd.get quit) in + let root = Lwd.observe t in + let rec loop () = + let quit = Lwd.quick_sample quit in + if not quit then ( + step ~process_event:true ?timeout:tick_period ~renderer term root; + tick (); + loop () + ) + in + loop (); + ignore (Lwd.quick_release root); + ignore (Lwd.quick_release quit) + + let run ?tick_period ?tick ?term ?(renderer=Renderer.make ()) + ?quit ?(quit_on_escape=true) ?(quit_on_ctrl_q=true) t = + let quit = match quit with + | Some quit -> quit + | None -> Lwd.var false + in + let t = Lwd.map t ~f:(Ui.event_filter (function + | `Key (`ASCII 'Q', [`Ctrl]) when quit_on_ctrl_q -> + Lwd.set quit true; `Handled + | `Key (`Escape, []) when quit_on_escape -> + Lwd.set quit true; `Handled + | _ -> `Unhandled + )) + in + match term with + | Some term -> run_with_term term ?tick_period ?tick ~renderer quit t + | None -> + let term = Term.create () in + run_with_term term ?tick_period ?tick ~renderer quit t; + Term.release term + +end diff --git a/vendor/lwd/nottui/nottui.mli b/vendor/lwd/nottui/nottui.mli new file mode 100644 index 00000000000..a4c72fe081e --- /dev/null +++ b/vendor/lwd/nottui/nottui.mli @@ -0,0 +1,370 @@ +open Notty + +(** + Nottui augments Notty with primitives for laying out user interfaces (in the + terminal) and reacting to input events. +*) + +(** {1 Focus (defining and managing active objects)} *) + +module Focus : +sig + + type handle + (** A [handle] represents a primitive area that can request, receive and lose + the focus. A visible UI is made of many handles, of which at most one can + be active. *) + + val make : unit -> handle + (** Create a new handle *) + + val request : handle -> unit + (** Request the focus *) + + val release : handle -> unit + (** Release the focus (if the handle has it) *) + + type status + (** [status] represents the state in which a handle can be. + Externally we care about having or not the focus, which can be queried + with the [has_focus] function. Internally, [status] also keeps track of + conflicts (if multiple handles [request]ed the focus). + *) + + val empty : status + (** A status that has no focus and no conflicts *) + + val status : handle -> status Lwd.t + (** Get the status of a focus [handle]. The [status] is a reactive value: + it will evolve over time, as focus is received or lost. *) + + val has_focus : status -> bool + (** Check if this [status] corresponds to an active focus *) + + (** TODO + This implements a more general concept of "reactive auction": + + - multiple parties are competing for a single resource (focus here, but + for instance a tab component can only display a single tab among many). + + - the result can evolve over time, parties can join or leave, or bid + "more". + *) +end + +(** {1 Gravity (horizontal and vertical alignments)} *) + +module Gravity : +sig + + type direction = [ + | `Negative + | `Neutral + | `Positive + ] + (** A gravity is a pair of directions along the horizontal and vertical + axis. + + Horizontal axis goes from left to right and vertical axis from top to + bottom. + + [`Negative] direction means left / top bounds, [`Neutral] means center + and [`Positive] means right / bottom. + *) + + val pp_direction : Format.formatter -> direction -> unit + (** Printing directions *) + + type t + (** The gravity type is a pair of an horizontal and a vertical gravity *) + + val pp : Format.formatter -> t -> unit + (** Printing gravities *) + + val make : h:direction -> v:direction -> t + (** Make a gravity value from an [h]orizontal and a [v]ertical directions. *) + + val default : t + (** Default (negative, aligning to the top-left) gravity. *) + + val h : t -> direction + (** Get the horizontal direction *) + + val v : t -> direction + (** Get the vertical direction *) + +end + +type gravity = Gravity.t + +(** {1 Primitive combinators for making user interfaces} *) + +module Ui : +sig + + type t + (* Type of UI elements *) + + val pp : Format.formatter -> t -> unit + (** Printing UI element *) + + (** {1 Layout specifications} *) + + type layout_spec = { w : int; h : int; sw : int; sh : int; } + (** The type of layout specifications. + + For each axis, layout is specified as a pair of integers: + - a fixed part that is expressed as a number of columns or rows + - a stretchable part that represents a strength used to share the + remaining space (or 0 if the UI doesn't extend over free space) + *) + + val pp_layout_spec : Format.formatter -> layout_spec -> unit + (** Printing layout specification *) + + val layout_spec : t -> layout_spec + (** Get the layout spec for an UI element *) + + val layout_width : t -> int + (** Get the layout width component of an UI element *) + + val layout_stretch_width : t -> int + (** Get the layout stretch width strength of an UI element *) + + val layout_height : t -> int + (** Get the layout height component of an UI element *) + + val layout_stretch_height : t -> int + (** Get the layout height strength of an UI element *) + + (** {1 Primitive images} *) + + val empty : t + (** The empty surface: it occupies no space and does not do anything *) + + val atom : image -> t + (** Primitive surface that displays a Notty image *) + + val space : int -> int -> t + (** Void space of dimensions [x,y]. Useful for padding and interstitial + space. *) + + (** {1 Event handles} *) + + type may_handle = [ `Unhandled | `Handled ] + (** An event is propagated until it gets handled. + Handler functions return a value of type [may_handle] to indicate + whether the event was handled or not. *) + + type mouse_handler = x:int -> y:int -> Unescape.button -> [ + | may_handle + | `Grab of (x:int -> y:int -> unit) * (x:int -> y:int -> unit) + ] + (** The type of handlers for mouse events. They receive the (absolute) + coordinates of the mouse, the button that was clicked. + + In return they indicate whether the event was handled or if the mouse is + "grabbed". + + When grabbed, two functions [on_move] and [on_release] should be + provided. The [on_move] function will be called when the mouse move while + the button is pressed and the [on_release] function is called when the + button is released. + + During that time, no other mouse input events can be dispatched. + *) + + type semantic_key = [ + (* Clipboard *) + | `Copy + | `Paste + (* Focus management *) + | `Focus of [`Next | `Prev | `Left | `Right | `Up | `Down] + ] + (** Key handlers normally reacts to keyboard input but a few special keys are + defined to represent higher-level actions. + Copy and paste, as well as focus movements. *) + + type key = [ + | Unescape.special | `Uchar of Uchar.t | `ASCII of char | semantic_key + ] * Unescape.mods + (** A key is the pair of a main key and a list of modifiers *) + + type mouse = Unescape.mouse + (** Specification of mouse inputs, taken from Notty *) + + type event = [ `Key of key | `Mouse of mouse | `Paste of Unescape.paste ] + (* The type of input events. *) + + val mouse_area : mouse_handler -> t -> t + (** Handle mouse events that happens over an ui. *) + + val keyboard_area : ?focus:Focus.status -> (key -> may_handle) -> t -> t + (** Define a focus receiver, handle keyboard events over the focused area *) + + val has_focus : t -> bool + (** Check if this UI has focus, either directly (it is a focused + [keyboard_area]), or inherited (one of the child is a focused + [keyboard_area]). *) + + val event_filter : + ?focus:Focus.status -> + ([`Key of key | `Mouse of mouse] -> may_handle) -> t -> t + (** A hook that intercepts and can interrupt events when they reach a + sub-part of the UI. *) + + (** {1 Sensors} + + Sensors are used to observe the physical dimensions after layout has been + resolved. + *) + + type size_sensor = w:int -> h:int -> unit + (** The size sensor callback tells you the [w]idth and [h]eight of UI. + The sensor is invoked only when the UI is visible. *) + + val size_sensor : size_sensor -> t -> t + (** Attach a size sensor to an image *) + + type frame_sensor = x:int -> y:int -> w:int -> h:int -> unit -> unit + (** The frame sensor callback gives you the whole rectangle where the widget + is displayed. + + The first for components are applied during before visiting children, + the last unit is applied after visiting children. + *) + + val transient_sensor : frame_sensor -> t -> t + (** Attach a transient frame sensor: the callback will be invoked only once, + on next frame. *) + + val permanent_sensor : frame_sensor -> t -> t + (** Attach a permanent sensor: the callback will be invoked on every frame. + Note that this can have a significant impact on performance. *) + + (** {1 Composite images} *) + + val resize : + ?w:int -> ?h:int -> ?sw:int -> ?sh:int -> + ?pad:Gravity.t -> ?crop:Gravity.t -> ?bg:attr -> t -> t + (** Override the layout specification of an image with provided [w], [h], + [sw] or [sh]. + + [pad] and [crop] are used to determine how to align the UI when there is + too much or not enough space. + + [bg] is used to fill the padded background. + *) + + val resize_to : + layout_spec -> + ?pad:Gravity.t -> ?crop:Gravity.t -> ?bg:attr -> t -> t + + val shift_area : int -> int -> t -> t + (** Shift the contents of a UI by a certain amount. + Positive values crop the image while negative values pad. + + This primitive is used to implement scrolling. + *) + + val join_x : t -> t -> t + (** Horizontally join two images *) + + val join_y : t -> t -> t + (** Vertically join two images *) + + val join_z : t -> t -> t + (** Superpose two images. The right one will be on top. *) + + val pack_x : t Lwd_utils.monoid + (** Horizontal concatenation monoid *) + + val pack_y : t Lwd_utils.monoid + (** Vertical concatenation monoid *) + + val pack_z : t Lwd_utils.monoid + (** Superposition monoid *) + + val hcat : t list -> t + (** Short-hand for horizontally joining a list of images *) + + val vcat : t list -> t + (** Short-hand for vertically joining a list of images *) + + val zcat : t list -> t + (** Short-hand for superposing a list of images *) +end + +type ui = Ui.t + +(** {1 Rendering user interfaces and dispatching input events} *) + +module Renderer : +sig + + type t + (** The type of a renderer *) + + type size = int * int + (** Size of a rendering surface, as a pair of width and height *) + + val make : unit -> t + (** Create a new renderer. + + It maintains state to update output image and to dispatch events. *) + + val update : t -> size -> Ui.t -> unit + (** Update the contents to be rendered to the given UI at a specific size *) + + val size : t -> size + (** Get the size of the last update *) + + val image : t -> image + (** Render and return actual image *) + + val dispatch_mouse : t -> Ui.mouse -> Ui.may_handle + (** Dispatch a mouse event *) + + val dispatch_key : t -> Ui.key -> Ui.may_handle + (** Dispatch a keyboard event *) + + val dispatch_event : t -> Ui.event -> Ui.may_handle + (** Dispatch an event *) + +end + +(** {1 Main loop} + + Outputting an interface to a TTY and interacting with it +*) + +module Ui_loop : +sig + open Notty_unix + + val step : ?process_event:bool -> ?timeout:float -> renderer:Renderer.t -> + Term.t -> ui Lwd.root -> unit + (** Run one step of the main loop. + + Update output image describe by the provided [root]. + If [process_event], wait up to [timeout] seconds for an input event, then + consume and dispatch it. *) + + val run : + ?tick_period:float -> ?tick:(unit -> unit) -> + ?term:Term.t -> ?renderer:Renderer.t -> + ?quit:bool Lwd.var -> ?quit_on_escape:bool -> + ?quit_on_ctrl_q:bool -> ui Lwd.t -> unit + (** Repeatedly run steps of the main loop, until either: + - [quit] becomes true, + - the ui computation raises an exception, + - if [quit_on_ctrl_q] was true or not provided, wait for Ctrl-Q event + - if [quit_on_escape] was true or not provided, wait for Escape event + + Specific [term] or [renderer] instances can be provided, otherwise new + ones will be allocated and released. + + To simulate concurrency in a polling fashion, tick function and period + can be provided. Use the [Lwt] backend for real concurrency. + *) +end diff --git a/vendor/pp/src/pp.ml b/vendor/pp/src/pp.ml index 0227704cec5..8a088c682cc 100644 --- a/vendor/pp/src/pp.ml +++ b/vendor/pp/src/pp.ml @@ -161,7 +161,6 @@ let rec to_fmt ppf t = Render.render ppf t ~tag_handler:(fun ppf _tag t -> to_fmt ppf t) let nop = Nop - let seq a b = Seq (a, b) let concat ?(sep = Nop) = function @@ -182,34 +181,22 @@ let concat_mapi ?(sep = Nop) l ~f = | l -> Concat (sep, List.mapi l ~f) let box ?(indent = 0) t = Box (indent, t) - let vbox ?(indent = 0) t = Vbox (indent, t) - let hbox t = Hbox t - let hvbox ?(indent = 0) t = Hvbox (indent, t) - let hovbox ?(indent = 0) t = Hovbox (indent, t) - let verbatim x = Verbatim x - let char x = Char x - let custom_break ~fits ~breaks = Break (fits, breaks) let break ~nspaces ~shift = custom_break ~fits:("", nspaces, "") ~breaks:("", shift, "") let space = break ~nspaces:1 ~shift:0 - let cut = break ~nspaces:0 ~shift:0 - let newline = Newline - let text s = Text s - let textf fmt = Printf.ksprintf text fmt - let tag tag t = Tag (tag, t) let enumerate l ~f = @@ -225,9 +212,9 @@ let chain l ~f = (seq (verbatim (if i = 0 then - " " - else - "-> ")) + " " + else + "-> ")) (f x))))) module O = struct @@ -235,3 +222,85 @@ module O = struct end let of_fmt f x = Format (fun ppf -> f ppf x) + +let compare = + let compare_both (type a b) (f : a -> a -> int) (g : b -> b -> int) (a, b) + (c, d) = + let r = f a c in + if r <> 0 then + r + else + g b d + in + (* Due to 4.08 lower bound, we need to define this here. *) + let rec compare_list a b ~cmp:f : int = + match (a, b) with + | [], [] -> 0 + | [], _ :: _ -> -1 + | _ :: _, [] -> 1 + | x :: a, y :: b -> ( + match (f x y : int) with + | 0 -> compare_list a b ~cmp:f + | ne -> ne) + in + fun compare_tag -> + let rec compare x y = + match (x, y) with + | Nop, Nop -> 0 + | Nop, _ -> -1 + | _, Nop -> 1 + | Seq (a, b), Seq (c, d) -> compare_both compare compare (a, b) (c, d) + | Seq _, _ -> -1 + | _, Seq _ -> 1 + | Concat (a, b), Concat (c, d) -> + compare_both compare (compare_list ~cmp:compare) (a, b) (c, d) + | Concat _, _ -> -1 + | _, Concat _ -> 1 + | Box (a, b), Box (c, d) -> compare_both Int.compare compare (a, b) (c, d) + | Box _, _ -> -1 + | _, Box _ -> 1 + | Vbox (a, b), Vbox (c, d) -> + compare_both Int.compare compare (a, b) (c, d) + | Vbox _, _ -> -1 + | _, Vbox _ -> 1 + | Hbox a, Hbox b -> compare a b + | Hbox _, _ -> -1 + | _, Hbox _ -> 1 + | Hvbox (a, b), Hvbox (c, d) -> + compare_both Int.compare compare (a, b) (c, d) + | Hvbox _, _ -> -1 + | _, Hvbox _ -> 1 + | Hovbox (a, b), Hovbox (c, d) -> + compare_both Int.compare compare (a, b) (c, d) + | Hovbox _, _ -> -1 + | _, Hovbox _ -> 1 + | Verbatim a, Verbatim b -> String.compare a b + | Verbatim _, _ -> -1 + | _, Verbatim _ -> 1 + | Char a, Char b -> Char.compare a b + | Char _, _ -> -1 + | _, Char _ -> 1 + | Break (a, b), Break (c, d) -> + let compare (x, y, z) (a, b, c) = + compare_both String.compare + (compare_both Int.compare String.compare) + (x, (y, z)) + (a, (b, c)) + in + compare_both compare compare (a, b) (c, d) + | Break _, _ -> -1 + | _, Break _ -> 1 + | Newline, Newline -> 0 + | Newline, _ -> -1 + | _, Newline -> 1 + | Text a, Text b -> String.compare a b + | Text _, _ -> -1 + | _, Text _ -> 1 + | Tag (a, b), Tag (c, d) -> compare_both compare_tag compare (a, b) (c, d) + | Format _, Format _ -> + raise + (Invalid_argument "[Pp.of_fmt] values not supported in [Pp.compare]") + | Format _, _ -> -1 + | _, Format _ -> 1 + in + compare diff --git a/vendor/pp/src/pp.mli b/vendor/pp/src/pp.mli index f625ad3e0ab..dd1f121688b 100644 --- a/vendor/pp/src/pp.mli +++ b/vendor/pp/src/pp.mli @@ -91,7 +91,9 @@ val newline : _ t And the top left corner of this shape is anchored where the box was declared. So for instance, the following document: - {[ Pp.verbatim "....." ++ Pp.box ~indent:2 (Pp.text "some long ... text") ]} + {[ + Pp.verbatim "....." ++ Pp.box ~indent:2 (Pp.text "some long ... text") + ]} would produce: @@ -209,3 +211,10 @@ val of_ast : 'a Ast.t -> 'a t (** [to_ast t] will try to convert [t] to [Ast.t]. When [t] contains values constructed with [of_fmt], this function will fail and return [Error ()] *) val to_ast : 'a t -> ('a Ast.t, unit) result + +(** {1 Comparison} *) + +(** [compare cmp x y] compares [x] and [y] using [cmp] to compare tags. + + @raise Invalid_argument if two [of_fmt] values are compared. *) +val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int diff --git a/vendor/update-lwd.sh b/vendor/update-lwd.sh new file mode 100755 index 00000000000..41680823026 --- /dev/null +++ b/vendor/update-lwd.sh @@ -0,0 +1,29 @@ +#!/bin/bash + +version=3c446b45b2d9e81bc72b57ada168fe7923f9b02c + +set -e -o pipefail + +TMP="$(mktemp -d)" +trap "rm -rf $TMP" EXIT + +rm -rf lwd +mkdir -p lwd/lwd lwd/nottui + +( + cd $TMP + git clone https://github.com/let-def/lwd.git + cd lwd + git checkout $version +) + +SRC=$TMP/lwd/ + +cp -v $SRC/LICENSE lwd/ +cp -v -R $SRC/lib/lwd/lwd.{ml,mli} lwd/lwd +cp -v -R $SRC/lib/lwd/lwd_utils.{ml,mli} lwd/lwd +cp -v -R $SRC/lib/nottui/nottui.{ml,mli} lwd/nottui + + +git checkout lwd/{lwd,nottui}/dune +git add -A . diff --git a/vendor/update-pp.sh b/vendor/update-pp.sh index 5f7998d1ea0..74b20c82216 100755 --- a/vendor/update-pp.sh +++ b/vendor/update-pp.sh @@ -1,6 +1,6 @@ -#!/bin/bash +#!/bin/sh -version=6be5e76d48806245255407b4d5881efe703cb5a0 +version=0021887f75a6017486908cfd837b2ee126e063e7 set -e -o pipefail @@ -23,4 +23,5 @@ cp -v $SRC/src/pp.{ml,mli} pp/src cp -v $SRC/LICENSE.md pp/ git checkout pp/src/dune +git checkout pp/LICENSE.md git add -A .