Compare commits

...

18 Commits

Author SHA1 Message Date
  Frédéric Bour bfc481aa54 WIP 3 months ago
  Frédéric Bour a995047176 implement permanent sensors 5 months ago
  Frédéric Bour b4447f82f3 wip 5 months ago
  Frédéric Bour fe42d56bf5 full_sensor before/after 6 months ago
  Frédéric Bour 9eb18e2207 Full_sensor trigger only once 6 months ago
  Frédéric Bour 07823fed56 full-sensor 6 months ago
  Frédéric Bour de82afccac fix unattached doc comments 5 months ago
  Frédéric Bour 75f4072ac8 Nottui_pretty: fix for OCaml 4.05 5 months ago
  Simon Cruanes b2b8f40a8b add toggle and basic file selector 6 months ago
  Simon Cruanes 417dbd6cd6 fix: avoid unicode problems in unfoldable 6 months ago
  Simon Cruanes a24e7f421c fix: keep proper alignment in unfoldable 6 months ago
  Frédéric Bour 7d2e152839 oops, reenable caching 6 months ago
  Frédéric Bour 7faf6d86c5 Pretty: specialize integer comparison 6 months ago
  Frédéric Bour ac32d8a5cf Tweak pretty example 6 months ago
  Frédéric Bour 6d46dfc677 Pretty example 6 months ago
  Frédéric Bour e714cdde9c No need to prove that abstract types in struct are different 6 months ago
  Frédéric Bour efff3a2102 Nottui_pretty 6 months ago
  Frédéric Bour 204a75e23c Lwd_seq: WIP perf/debug comments 6 months ago
13 changed files with 966 additions and 206 deletions
Split View
  1. +9
    -0
      Makefile
  2. +6
    -0
      dune-project
  3. +6
    -0
      examples/dune
  4. +14
    -6
      examples/minimal.ml
  5. +76
    -0
      examples/pretty.ml
  6. +6
    -0
      lib/lwd/lwd_seq.ml
  7. +3
    -0
      lib/nottui-pretty/dune
  8. +390
    -0
      lib/nottui-pretty/nottui_pretty.ml
  9. +57
    -0
      lib/nottui-pretty/nottui_pretty.mli
  10. +168
    -43
      lib/nottui-widgets/nottui_widgets.ml
  11. +198
    -152
      lib/nottui/nottui.ml
  12. +8
    -5
      lib/nottui/nottui.mli
  13. +25
    -0
      nottui-pretty.opam

+ 9
- 0
Makefile View File

@@ -3,6 +3,9 @@ all:

TESTS=minimal misc reranger stress

$(TESTS):
dune build examples/$@.bc

run-minimal:
dune exec examples/minimal.bc

@@ -15,6 +18,12 @@ run-reranger:
run-stress:
dune exec examples/stress.bc

run-pretty:
dune exec examples/pretty.bc

run-pretty-lambda:
dune exec examples/pretty_lambda.bc

run-stress.exe:
dune exec examples/stress.exe



+ 6
- 0
dune-project View File

@@ -21,6 +21,12 @@
(description "TODO")
(depends dune lwd notty))

(package
(name nottui-pretty)
(synopsis "A pretty-printer based on PPrint rendering UIs")
(description "TODO")
(depends dune notty lwt nottui))

(package
(name nottui-lwt)
(synopsis "Run Nottui UIs in Lwt")


+ 6
- 0
examples/dune View File

@@ -17,3 +17,9 @@
(name stress)
(modules stress)
(libraries notty notty.unix nottui nottui-widgets))

(executable
(name pretty)
(modules pretty)
(libraries nottui-pretty notty notty.unix nottui nottui-widgets))


+ 14
- 6
examples/minimal.ml View File

@@ -73,12 +73,20 @@ let celsius_edit =
~on_submit:ignore

let root =
Lwd_utils.pack Ui.pack_y [
Lwd.pure (Nottui_widgets.string "Celsius:");
celsius_edit;
Lwd.pure (Nottui_widgets.string "Farenheight:");
farenheit_edit;
]
let base =
Lwd_utils.pack Ui.pack_y [
Lwd.pure (Nottui_widgets.string "Celsius:");
celsius_edit;
Lwd.pure (Nottui_widgets.string "Farenheight:");
farenheit_edit;
]
in
let base = Lwd.map2 Ui.join_y base base in
let base = Lwd.map2 Ui.join_y base base in
let base = Lwd.map2 Ui.join_y base base in
let base = Lwd.map2 Ui.join_y base base in
let base = Lwd.map2 Ui.join_y base base in
base

(*let () = Statmemprof_emacs.start 1E-4 30 5*)



+ 76
- 0
examples/pretty.ml View File

@@ -0,0 +1,76 @@
open Nottui
module P = Nottui_pretty

let string ?attr text = P.ui (Nottui_widgets.string ?attr text)

let (^^) = P.(^^)
let (^/^) a b = P.(a ^^ break 1 ^^ b)


let spring = P.ui (Ui.resize ~sw:1 Ui.empty)

let selector text f choices =
Nottui_widgets.main_menu_item text (fun () ->
Lwd.pure @@
Lwd_utils.pure_pack Ui.pack_y (
List.map
(fun choice ->
Nottui_widgets.sub_entry choice (fun () -> f choice))
choices
)
)

let fruit =
let fruits = ["Apple"; "Orange"; "Strawberry"] in
let choice = Lwd.var (List.hd fruits) in
Lwd.join (
Lwd.map' (Lwd.get choice) (fun current ->
selector current (Lwd.set choice) fruits
)
)

let doc = Lwd_table.make ()

let () =
for _ = 0 to 99 do
List.iter (fun doc' -> Lwd_table.append' doc (Lwd.pure doc'))
[
P.group (string "This" ^/^ string "is" ^/^ string "pretty.");
P.hardline; P.ui (Nottui.Ui.void 0 1); P.hardline;
P.group (P.group (string "This" ^/^ string "is") ^/^ string "pretty.");
P.hardline; P.ui (Nottui.Ui.void 0 1); P.hardline;
P.group (string "This" ^/^ P.group (string "is" ^/^ string "pretty."));
P.hardline; P.ui (Nottui.Ui.void 0 1); P.hardline;
P.group (spring ^^ string "This" ^^ spring ^/^
P.group (string "is" ^^ spring ^/^ string "pretty.") ^^ spring);
P.hardline; P.ui (Nottui.Ui.void 0 1); P.hardline;
];
Lwd_table.append' doc
(Lwd.map' fruit (fun fruit ->
P.group (spring ^^ string "I" ^^ spring ^/^
P.group (string "like" ^^ spring ^/^
P.ui fruit ^^ spring ^/^
string "more.") ^^ spring);
))
done

let varying_width f =
let width = Lwd.var 0 in
Lwd.map'
(f (Lwd.get width))
(fun ui ->
Nottui.Ui.size_sensor
(fun w _ -> if Lwd.peek width <> w then Lwd.set width w)
(Nottui.Ui.resize ~sw:1 ~sh:1 ~w:0 ui))

let doc =
Lwd.join (Lwd_table.reduce (Lwd_utils.lift_monoid (P.empty, P.(^^))) doc)

let contents width = Lwd.map2' width doc P.pretty

let () =
Nottui.Ui_loop.run (
Nottui_widgets.h_pane
(Nottui_widgets.scroll_area (varying_width contents))
(Lwd.pure Nottui.Ui.empty)
)

+ 6
- 0
lib/lwd/lwd_seq.ml View File

@@ -339,6 +339,7 @@ module Reducer = struct
| XEmpty, Nil -> no_dropped, XEmpty
| (XLeaf {a; _} | XJoin {a; _}), _ when a == tnew -> no_dropped, xold
| _ ->
(* Cost: 16 words *)
let qold = Queue.create () and sold = mk_stats () in
let qnew = Queue.create () and snew = mk_stats () in
begin match xold with
@@ -357,10 +358,15 @@ module Reducer = struct
shared_x = Array.make (sold.shared + snew.shared) [];
shared_index = 0;
} in
(*Printf.eprintf "sold.shared:%d sold.marked:%d sold.blocked:%d\n%!"
sold.shared sold.marked sold.blocked;
Printf.eprintf "snew.shared:%d snew.marked:%d snew.blocked:%d\n%!"
snew.shared snew.marked snew.blocked;*)
unmark_old st xold;
assert (st.dropped_leaf = st.dropped_join);
prepare_shared st;
let result = unmark_new st tnew in
(*Printf.eprintf "new_computed:%d%!\n" !new_computed;*)
let restore_rank = function
| Nil -> assert false
| Leaf t -> t.mark <- 0


+ 3
- 0
lib/nottui-pretty/dune View File

@@ -0,0 +1,3 @@
(library (name nottui_pretty)
(public_name nottui-pretty)
(libraries nottui))

+ 390
- 0
lib/nottui-pretty/nottui_pretty.ml View File

@@ -0,0 +1,390 @@
(**************************************************************************)
(* *)
(* Nottui_pretty, pretty-printer for Nottui *)
(* Frédéric Bour, Tarides *)
(* Copyright 2020 Tarides. All rights reserved. *)
(* *)
(* Based on PPrint *)
(* François Pottier, Inria Paris *)
(* Nicolas Pouillard *)
(* *)
(* Copyright 2007-2019 Inria. All rights reserved. This file is *)
(* distributed under the terms of the GNU Library General Public *)
(* License, with an exception, as described in the file LICENSE. *)
(**************************************************************************)

(* -------------------------------------------------------------------------- *)

(* A type of integers with infinity. *)

type requirement =
int (* with infinity *)

(* Infinity is encoded as [max_int]. *)

let infinity : requirement =
max_int

(* Addition of integers with infinity. *)

let (++) (x : requirement) (y : requirement) : requirement =
if x = infinity || y = infinity
then infinity
else x + y

(* --------------------------------------------------------------------------
UI cache
--------------------------------------------------------------------------

It serves two purposes: representing intermediate UI and caching it.

The cache part is used to speed-up re-computation. It stores the conditions
under which the cached result is the "prettiest" solution.
A flat layout cannot change, so there is no extra condition.
Optimality of non-flat layout is determined by two intervals:
- `min_rem..max_rem`, the remaining space on the current line
- `min_wid..max_wid`, the width of new lines (e.g. maximum width - indent)

The intermediate UI part is necessary because pretty-printing produces two
type of shapes, line and span, while [Nottui.ui] can only represent lines.
Conceptually [Nottui.ui] represents a box, with a width and a height.
However in the middle of pretty-printing, we can get in situations where a
few lines have already been typeset and we stop in the middle of a new line.
In full generality, span represents UI that look like that:

... [ prefix ]
[ 0 or more ]
[ body lines ]
[ suffix ] ...

Prefix is the first line of the intermediate UI, to which we might prepend
something.
Body is the lines that are fully typeset and won't change. It can be empty.
Suffix is the last line of the intermediate UI, to which we might append
something.

FUTURE WORK: since flat layout never changes, it might be worth caching
separately flat and non-flat results. Flat cache would actually be a lazy
computation.
*)

(* We use a few OCaml tricks to implement caching without introducing too
much indirections.
These optimisations are worthy because of the live/interactive nature of
Nottui_pretty (documents are long-lived). This is not the case for PPrint.
*)

type ui = Nottui.ui

(* Category of intermediate nodes *)
type flat
type nonflat
type uncached

type 'a ui_cache =
| (* A placeholder for a cache that is empty *)
Uncached : uncached ui_cache
| (* A single line that is flat *)
Flat_line : ui -> flat ui_cache
| (* Flat_span is a bit strange...
It can only occur when someone put a `Hardline` in a flat document.
They lied: the document should have been flat, but it is not.
Nevertheless, I chose to accept this case. *)
Flat_span : { prefix: ui; body: ui; suffix: ui } -> flat ui_cache
| (* A line in a non-flat context *)
Nonflat_line : { min_rem: int; max_rem: int; ui: ui; } -> nonflat ui_cache
| (* A span in a non-flat context *)
Nonflat_span : {
min_rem: int; max_rem: int; prefix: ui;
min_wid: int; max_wid: int; body: ui; suffix: ui;
} -> nonflat ui_cache

(* The type of an actual cache slot (stored in document nodes).
It hides the category of the node. *)
type ui_cache_slot = Cache : 'a ui_cache -> ui_cache_slot [@@ocaml.unboxed]

(* -------------------------------------------------------------------------- *)

(* The type of documents. *)

type t =
| Blank of int
| Ui of Nottui.ui
| If_flat of { then_: t; else_: t }
| Hardline
| Cat of { req: requirement; lhs: t; rhs: t; mutable cache : ui_cache_slot }
| Nest of { req: requirement; indent: int; doc: t }
| Group of { req: requirement; doc: t; mutable cache : ui_cache_slot }

(* Only [Cat] and [Group] nodes are cached.
This is because [Cat] is the only place where two sub-documents are
connected. Cache miss here can change the asymptotic complexity of the
computation.
[Group] nodes are the only one where decisions are made (flat or non-flat).
Other nodes, are either leaves ([Blank], [Ui], [Hardline]) or
should normally only have a fixed nesting ([Nest (Nest (Nest ...))] cannot
happen). I suspect that caching is not beneficial, if detrimental, to these
cases.
*)

(* -------------------------------------------------------------------------- *)

(* Retrieving or computing the space requirement of a document. *)

let rec requirement = function
| Blank len -> len
| Ui ui -> Nottui.Ui.layout_width ui
| If_flat t -> requirement t.then_
| Hardline -> infinity
| Cat {req; _} | Nest {req; _} | Group {req; _} -> req

(* -------------------------------------------------------------------------- *)

(* Document constructors. *)

let empty = Blank 0

let ui ui = Ui ui

let hardline = Hardline

let blank = function
| 0 -> Blank 0
| 1 -> Blank 1
| n -> Blank n

let if_flat (If_flat {then_; _} | then_) else_ =
If_flat { then_; else_ }

let internal_break i =
if_flat (blank i) hardline

let break =
let break0 = internal_break 0 in
let break1 = internal_break 1 in
function
| 0 -> break0
| 1 -> break1
| i -> internal_break i

let (^^) x y =
match x, y with
| (Blank 0, t) | (t, Blank 0) -> t
| Blank i, Blank j -> Blank (i + j)
| lhs, rhs ->
Cat {req = requirement lhs ++ requirement rhs; lhs; rhs;
cache = Cache Uncached}

let nest indent doc =
assert (indent >= 0);
match doc with
| Nest t -> Nest {req = t.req; indent = indent + t.indent; doc = t.doc}
| doc -> Nest {req = requirement doc; indent; doc}

let group = function
| Group _ as doc -> doc
| doc ->
let req = requirement doc in
if req = infinity then doc else Group {req; doc; cache = Cache Uncached}

(* -------------------------------------------------------------------------- *)

open Nottui

(* Some intermediate UI *)

let blank_ui =
let space = Ui.atom (Notty.I.void 1 0) in
function
| 0 -> Ui.empty
| 1 -> space
| n -> Ui.atom (Notty.I.void n 0)

let flat_hardline =
Flat_span { prefix = Ui.empty; body = Ui.empty; suffix = Ui.empty; }

let mk_body body1 suffix prefix body2 =
Ui.join_y body1 (Ui.join_y (Ui.join_x suffix prefix) body2)

let mk_pad indent body suffix =
let pad = Ui.void indent 0 in
(Ui.join_x pad body, Ui.join_x pad suffix)

(* Flat renderer *)

let flat_cache (Cache slot) = match slot with
| Flat_line _ as ui -> Some ui
| Flat_span _ as ui -> Some ui
| _ -> None

let rec pretty_flat = function
| Ui ui -> Flat_line ui
| Blank n -> Flat_line (blank_ui n)
| Hardline -> flat_hardline
| If_flat t -> pretty_flat t.then_
| Cat t ->
begin match flat_cache t.cache with
| Some ui -> ui
| None ->
let result =
let lhs = pretty_flat t.lhs and rhs = pretty_flat t.rhs in
match lhs, rhs with
| Flat_line l, Flat_line r ->
Flat_line (Ui.join_x l r)
| Flat_line l, Flat_span r ->
Flat_span {r with prefix = Ui.join_x l r.prefix}
| Flat_span l, Flat_line r ->
Flat_span {l with suffix = Ui.join_x l.suffix r}
| Flat_span l, Flat_span r ->
Flat_span {prefix = l.prefix;
body = mk_body l.body l.suffix r.prefix r.body;
suffix = r.suffix}
in
t.cache <- Cache result;
result
end
| Nest t ->
begin match pretty_flat t.doc with
| Flat_line _ as ui -> ui
| Flat_span s ->
let body, suffix = mk_pad t.indent s.body s.suffix in
Flat_span {s with body; suffix}
end
| Group t ->
begin match flat_cache t.cache with
| Some ui -> ui
| None ->
let result = pretty_flat t.doc in
t.cache <- Cache result;
result
end

(* Nonflat renderer.

Steps:
- check cache validity
- compute normal, non-interactive pretty-printing
- cache result and determine validity conditions

The three steps could be implemented separately, but doing so would
introduce redundant checks or indirections.
For performance reasons and to reduce memory pressure, I preferred
this ugly 100-lines long implementation.
*)

let maxi i j : int = if i < j then j else i
let mini i j : int = if i < j then i else j
let (+++) i j = let result = i + j in if result < 0 then max_int else result

let nonflat_line ui =
Nonflat_line {min_rem = min_int; max_rem = max_int; ui}

let nonflat_cache (Cache slot) rem wid = match slot with
| Nonflat_line t' as t when t'.min_rem <= rem && rem < t'.max_rem -> Some t
| Nonflat_span t' as t
when t'.min_rem <= rem && rem < t'.max_rem &&
t'.min_wid <= wid && wid < t'.max_wid -> Some t
| _ -> None

let span_hardline = Nonflat_span {
min_rem = min_int; max_rem = max_int;
min_wid = min_int; max_wid = max_int;
prefix = Ui.empty; body = Ui.empty; suffix = Ui.empty;
}

let rec pretty (rem: int) (wid : int) = function
| Ui ui -> nonflat_line ui
| Blank n -> nonflat_line (blank_ui n)
| Hardline -> span_hardline
| If_flat t -> pretty rem wid t.else_
| Cat t ->
begin match nonflat_cache t.cache rem wid with
| Some ui -> ui
| None ->
let lhs = pretty rem wid t.lhs in
let result = match lhs with
| Nonflat_line l ->
let lw = Ui.layout_width l.ui in
begin match pretty (rem - lw) wid t.rhs with
| Nonflat_line r ->
Nonflat_line {
min_rem = maxi l.min_rem (r.min_rem + lw);
max_rem = mini l.max_rem (r.max_rem +++ lw);
ui = Ui.join_x l.ui r.ui;
}
| Nonflat_span r ->
Nonflat_span {
r with
min_rem = maxi l.min_rem (r.min_rem + lw);
max_rem = mini l.max_rem (r.max_rem +++ lw);
prefix = Ui.join_x l.ui r.prefix;
}
end
| Nonflat_span l ->
let lw = Ui.layout_width l.suffix in
begin match pretty (wid - lw) wid t.rhs with
| Nonflat_line r ->
Nonflat_span {
l with
min_wid = maxi l.min_wid (r.min_rem + lw);
max_wid = mini l.max_wid (r.max_rem +++ lw);
suffix = Ui.join_x l.suffix r.ui;
}
| Nonflat_span r ->
Nonflat_span {
prefix = l.prefix; min_rem = l.min_rem; max_rem = l.max_rem;
min_wid = maxi (maxi l.min_wid (r.min_rem + lw)) r.min_wid;
max_wid = mini (mini l.max_wid (r.max_rem +++ lw)) r.max_wid;
body = mk_body l.body l.suffix r.prefix r.body;
suffix = r.suffix;
}
end
in
t.cache <- Cache result;
result
end
| Nest t ->
begin match pretty rem (wid - t.indent) t.doc with
| Nonflat_line _ as ui -> ui
| Nonflat_span s ->
let body, suffix = mk_pad t.indent s.body s.suffix in
Nonflat_span {
min_rem = s.min_rem; max_rem = s.max_rem;
min_wid = s.min_wid + t.indent;
max_wid = s.max_wid +++ t.indent;
prefix = s.prefix; body; suffix;
}
end
| Group t as self ->
begin if t.req <= rem then
match pretty_flat self with
| Flat_line ui ->
Nonflat_line { min_rem = t.req; max_rem = max_int; ui }
| Flat_span ui ->
Nonflat_span {
min_rem = t.req; max_rem = max_int;
min_wid = min_int; max_wid = max_int;
prefix = ui.prefix;
body = ui.body;
suffix = ui.suffix;
}
else match nonflat_cache t.cache rem wid with
| Some ui -> ui
| None ->
let result = match pretty rem wid t.doc with
| Nonflat_line ui -> Nonflat_line {ui with max_rem = t.req}
| Nonflat_span ui ->
Nonflat_span {ui with max_rem = mini t.req ui.max_rem}
in
t.cache <- Cache result;
result
end

(* -------------------------------------------------------------------------- *)

(* The engine's entry point. *)

let pretty width doc =
match pretty width width doc with
| Nonflat_line t -> t.ui
| Nonflat_span t -> Ui.join_y t.prefix (Ui.join_y t.body t.suffix)

+ 57
- 0
lib/nottui-pretty/nottui_pretty.mli View File

@@ -0,0 +1,57 @@
(**************************************************************************)
(* *)
(* Nottui_pretty, pretty-printer for Nottui *)
(* Frédéric Bour, Tarides *)
(* Copyright 2020 Tarides. All rights reserved. *)
(* *)
(* Based on PPrint *)
(* François Pottier, Inria Paris *)
(* Nicolas Pouillard *)
(* *)
(* Copyright 2007-2019 Inria. All rights reserved. This file is *)
(* distributed under the terms of the GNU Library General Public *)
(* License, with an exception, as described in the file LICENSE. *)
(**************************************************************************)

(* The type of documents *)
type t

(* The empty document *)
val empty : t

(* A document representing a UI widget *)
val ui : Nottui.ui -> t

(* Forced line break *)
val hardline : t

(* White space *)
val blank : int -> t

(* Choose between two documents based on whether we are in flat-mode or not.
First document should not force any hardline, otherwise it will completely
disable flat mode (... it is not possible to be flat and have hardlines).
*)
val if_flat : t -> t -> t

(* [break n] behaves like [blank n] if flat or [hardline] if non-flat:
If it fits on current line it displays [n] whitespaces, if not it breaks the
current line. *)
val break : int -> t

(* Concatenate two documents *)
val ( ^^ ) : t -> t -> t

(* [nest n t] increases indentation level by [n] inside document [t]:
if a new line has to be introduced in the layout [t], it will be shifted on
the right by [n] columns. *)
val nest : int -> t -> t

(* [group t] introduces a choice point.
If sub-documnet [t] fits on the current-line, it will be printed in flat
mode.
Otherwise [t] is printed as usual. *)
val group : t -> t

(* [pretty w t] renders document [t] targetting optimal width [w]. *)
val pretty : int -> t -> Nottui.ui

+ 168
- 43
lib/nottui-widgets/nottui_widgets.ml View File

@@ -48,13 +48,15 @@ let attr_menu_main = A.(bg green ++ fg black)
let attr_menu_sub = A.(bg lightgreen ++ fg black)

let menu_overlay ?dx ?dy handler t =
let placeholder = Lwd.return (Ui.atom (I.void 1 0)) in
ignore (dx, dy, handler, t);
assert false
(*let placeholder = Lwd.return (Ui.atom (I.void 1 0)) in
let body = Lwd_utils.pack Ui.pack_x [placeholder; t; placeholder] in
let bg = Lwd.map' body @@ fun t ->
let {Ui. w; h; _} = Ui.layout_spec t in
Ui.atom (I.char A.(bg lightgreen) ' ' w h)
in
Lwd.map (Ui.overlay ?dx ?dy ~handler) (Lwd_utils.pack Ui.pack_z [bg; body])
Lwd.map (Ui.overlay ?dx ?dy ~handler) (Lwd_utils.pack Ui.pack_z [bg; body])*)

let scroll_step = 1

@@ -95,7 +97,7 @@ let vscroll_area ~state ~change t =
t
|> Ui.scroll_area 0 state.position
|> Ui.resize ~h:0 ~sh:1
|> Ui.size_sensor (fun _ h ->
|> Ui.size_sensor (fun ~w:_ ~h ->
let tchange =
if !total <> (Ui.layout_spec t).Ui.h
then (total := (Ui.layout_spec t).Ui.h; true)
@@ -230,7 +232,7 @@ let v_pane left right =
in
splitter $= Lwd.map (Ui.mouse_area action) (Lwd.get splitter_bg);
render ();
let on_resize ew eh =
let on_resize ~w:ew ~h:eh =
if !w <> ew || !h <> eh then (
w := ew; h := eh;
render ()
@@ -239,44 +241,112 @@ let v_pane left right =
Lwd.map' node @@ fun t ->
Ui.size_sensor on_resize (Ui.resize ~w:10 ~h:10 ~sw:1 ~sh:1 t)

let h_pane top bottom =
let w = ref 10 in
let h = ref 10 in
let split = ref 0.5 in
let splitter = Lwd.var empty_lwd in
let splitter_bg = Lwd.var Ui.empty in
let top_pane = Lwd.var empty_lwd in
let bot_pane = Lwd.var empty_lwd in
let node = Lwd_utils.pack Ui.pack_x [!$top_pane; !$splitter; !$bot_pane] in
let render () =
let split = int_of_float (!split *. float !w) in
let split = min (!w - 1) (max split 0) in
top_pane $= Lwd.map' top
(fun t -> Ui.resize ~w:split ~h:!h t);
bot_pane $= Lwd.map' bottom
(fun t -> Ui.resize ~w:(!w - split - 1) ~h:!h t);
splitter_bg $= Ui.atom (Notty.I.char Notty.A.(bg lightyellow) ' ' 1 !h);
in
let action ~x:_ ~y:_ = function
| `Left ->
let x0 = int_of_float (!split *. float !w) in
`Grab ((fun ~x ~y:_ ->
let x0' = x0 + x in
split := min 1.0 (max 0.0 (float x0' /. float !w));
render ()
), (fun ~x:_ ~y:_ -> ()))
| _ -> `Unhandled
type pane_state =
| Split of { pos: int; max: int }
| Re_split of { pos: int; max: int; at: int }

let h_pane l r =
let state_var = Lwd.var (Split {pos = 5; max = 10}) in
let render state (l, r) =
let (Split {pos; max} | Re_split {pos; max; _}) = state in
let l = Ui.resize ~w:0 ~h:0 ~sh:1 ~sw:pos l in
let r = Ui.resize ~w:0 ~h:0 ~sh:1 ~sw:(max - pos) r in
let splitter =
Ui.resize ~bg:Notty.A.(bg lightyellow) ~w:1 ~h:0 ~sw:0 ~sh:1 Ui.empty
in
let splitter =
Ui.mouse_area (fun ~x:_ ~y:_ -> function
| `Left ->
`Grab (
(fun ~x ~y:_ ->
match Lwd.peek state_var with
| Split {pos; max} ->
Lwd.set state_var (Re_split {pos; max; at = x})
| Re_split {pos; max; at} ->
if at <> x then
Lwd.set state_var (Re_split {pos; max; at = x})
),
(fun ~x:_ ~y:_ -> ())
)
| _ -> `Unhandled
) splitter
in
let ui = Ui.join_x l (Ui.join_x splitter r) in
let ui = Ui.resize ~w:10 ~h:10 ~sw:1 ~sh:1 ui in
let ui = match state with
| Split _ -> ui
| Re_split {at; _} ->
Ui.transient_sensor (fun ~x ~y:_ ~w ~h:_ () ->
Lwd.set state_var (Split {pos = (at - x); max = w})
) ui
in
ui
in
splitter $= Lwd.map (Ui.mouse_area action) (Lwd.get splitter_bg);
render ();
let on_resize ew eh =
if !w <> ew || !h <> eh then (
w := ew; h := eh;
render ()
)
Lwd.map2 render (Lwd.get state_var) (Lwd.pair l r)

(*type pane_state =
| Static of { w : int; h : int; split : float }
| Resizing of { w : int; h : int; split : float; x : int; y : int; }

let pane_h (Static {h; _} | Resizing {h; _}) = h
let pane_w (Static {w; _} | Resizing {w; _}) = w
let pane_split (Static {split; _} | Resizing {split; _}) = split

let h_pane l r =
let state_var = Lwd.var (Static {w = 0; h = 0 ; split = 0.5}) in
let render state (l, r) =
let h = pane_h state in
let split = int_of_float (pane_split state *. float (pane_w state)) in
let l = Ui.resize ~w:split ~h l in
let r = Ui.resize ~w:(pane_w state - split - 1) ~h r in
let splitter = Ui.atom (Notty.I.char Notty.A.(bg lightyellow) ' ' 1 h) in
let splitter =
Ui.mouse_area (fun ~x:_ ~y:_ -> function
| `Left ->
`Grab (
(fun ~x ~y:_ ->
match Lwd.peek state_var with
| Static {w; h; split} ->
Lwd.set state_var (Resizing {x = min_int; y = min_int; w; h; split})
| Resizing r ->
if r.x > min_int then
let split = float (x - r.x) /. float r.w in
Lwd.set state_var (Resizing {r with split})
),
(fun ~x:_ ~y:_ ->
match Lwd.peek state_var with
| Static _ -> ()
| Resizing {w; h; split; _} ->
Lwd.set state_var (Static {w; h; split})
)
)
| _ -> `Unhandled
) splitter
in
let ui = Ui.join_x l (Ui.join_x splitter r) in
let ui = Ui.resize ~w:10 ~h:10 ~sw:1 ~sh:1 ui in
let ui = match state with
| Static _ ->
Ui.size_sensor (fun ~w ~h ->
match Lwd.peek state_var with
| Static r ->
if r.w <> w || r.h <> h then
Lwd.set state_var (Static {r with w; h})
| Resizing _ -> ()
) ui
| Resizing _ ->
Ui.permanent_sensor (fun ~x ~y ~w ~h ->
match Lwd.peek state_var with
| Static _ -> ignore
| Resizing r ->
if r.x <> x || r.y <> y || r.w <> w || r.h <> h then
Lwd.set state_var (Resizing {x; y; w; h; split = r.split});
ignore
) ui
in
ui
in
Lwd.map' node @@ fun t ->
Ui.size_sensor on_resize (Ui.resize ~w:10 ~h:10 ~sw:1 ~sh:1 t)
Lwd.map2 render (Lwd.get state_var) (Lwd.pair l r)*)

let sub' str p l =
if p = 0 && l = String.length str
@@ -419,9 +489,9 @@ let unfoldable ?(folded_by_default=true) summary (f: unit -> Ui.t Lwd.t) : Ui.t
in
(* pad summary with a "> " when it's opened *)
let summary =
Lwd.get opened >>= function
| true -> Lwd.map (Ui.join_x (string "🔽")) summary
| false -> Lwd.map (Ui.join_x (string "▶️ ")) summary
Lwd.get opened >>= fun op ->
summary >|= fun s ->
Ui.hcat [string ~attr:A.(bg blue) (if op then "v" else ">"); string " "; s]
in
let cursor ~x:_ ~y:_ = function
| `Left when Lwd.peek opened -> Lwd.set opened false; `Handled
@@ -558,3 +628,58 @@ let grid
let button ?attr s f =
Ui.mouse_area (fun ~x:_ ~y:_ _ -> f(); `Handled) (string ?attr s)


(* file explorer for selecting a file *)
let file_select
?(abs=false)
?filter
~(on_select:string -> unit) () : Ui.t Lwd.t =
let rec aux ~fold path =
try
let p_rel = if path = "" then "." else path in
if Sys.is_directory p_rel then (
let ui() =
let arr = Sys.readdir p_rel in
let l = Array.to_list arr |> List.map (Filename.concat path) in
(* apply potential filter *)
let l = match filter with None -> l | Some f -> List.filter f l in
let l = Lwd.return @@ List.sort String.compare l in
vlist_with ~bullet:"" (aux ~fold:true) l
in
if fold then (
unfoldable ~folded_by_default:true
(Lwd.return @@ string @@ path ^ "/") ui
) else ui ()
) else (
Lwd.return @@
button ~attr:A.(st underline) path (fun () -> on_select path)
)
with e ->
Lwd.return @@ Ui.vcat [
printf ~attr:A.(bg red) "cannot list directory %s" path;
string @@ Printexc.to_string e;
]
in
let start = if abs then Sys.getcwd () else "" in
aux ~fold:false start

let toggle, toggle' =
let toggle_ st (lbl:string Lwd.t) (f:bool -> unit) : Ui.t Lwd.t =
let mk_but st_v lbl_v =
let lbl = Printf.sprintf "[%s|%s]" lbl_v (if st_v then "✔" else "×");in
button lbl (fun () ->
let new_st = not st_v in
Lwd.set st new_st; f new_st)
in
Lwd.map2 mk_but (Lwd.get st) lbl
in
(* Similar to {!toggle}, except it directly reflects the state of a variable. *)
let toggle' (lbl:string Lwd.t) (v:bool Lwd.var) : Ui.t Lwd.t =
toggle_ v lbl (Lwd.set v)
(* a toggle, with a true/false state *)
and toggle ?(init=false) (lbl:string Lwd.t) (f:bool -> unit) : Ui.t Lwd.t =
let st = Lwd.var init in
toggle_ st lbl f
in
toggle, toggle'


+ 198
- 152
lib/nottui/nottui.ml View File

@@ -81,9 +81,6 @@ sig
val h : t -> direction
val v : t -> direction

val bottom_left : t
val bottom_right : t

type t2
val pair : t -> t -> t2
val p1 : t2 -> t
@@ -112,9 +109,6 @@ struct
let h x = unpack (x lsr 2)
let v x = unpack (x land 3)

let bottom_left = make ~h:`Negative ~v:`Positive
let bottom_right = make ~h:`Positive ~v:`Positive

let pp_direction ppf dir =
let text = match dir with
| `Negative -> "`Negative"
@@ -134,6 +128,35 @@ struct
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 ]
@@ -165,42 +188,41 @@ struct
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 'a desc =
| Atom of image
| Size_sensor of 'a * (int -> int -> unit)
| Resize of 'a * Gravity.t2 * A.t
| Mouse_handler of 'a * mouse_handler
| Focus_area of 'a * (key -> may_handle)
| Scroll_area of 'a * int * int
| Event_filter of 'a * ([`Key of key | `Mouse of mouse] -> may_handle)
| Overlay of 'a overlay
| X of 'a * 'a
| Y of 'a * 'a
| Z of 'a * 'a

and 'a overlay = {
o_n : 'a;
o_h : mouse_handler;
o_x : int;
o_y : int;
o_z : int;
o_origin : Gravity.t;
o_direction : Gravity.t;
}
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;
desc : t desc;
mutable desc : desc;
focus : Focus.status;
mutable flags : flags;
mutable sensor_cache : (int * int * int * int) option;
mutable cache : cache;
}
and cache = {
vx1 : int; vy1 : int;
vx2 : int; vy2 : int;
vx : Interval.t; vy : Interval.t;
image : image;
overlays: t overlay list;
}
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)
| Scroll_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 }
@@ -210,18 +232,19 @@ struct
let layout_stretch_height t = t.sh

let cache : cache =
{ vx1 = 0; vy1 = 0; vx2 = 0; vy2 = 0;
image = I.empty; overlays = [] }
{ vx = Interval.zero; vy = Interval.zero; image = I.empty }

let empty : t =
{ w = 0; sw = 0; h = 0; sh = 0;
focus = Focus.empty; desc = Atom I.empty; cache }
{ 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;
desc = Atom img; cache }
focus = Focus.empty; flags = flags_none;
desc = Atom img;
sensor_cache = None; cache; }

let void x y = atom (I.void x y)

@@ -241,6 +264,14 @@ struct
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 resize ?w ?h ?sw ?sh ?fill ?crop ?(bg=A.empty) t : t =
let g = match fill, crop with
| None, None -> Gravity.(pair default default)
@@ -252,19 +283,6 @@ struct
(Some sw, _ | None, sw), (Some sh, _ | None, sh) ->
{t with w; h; sw; sh; desc = Resize (t, g, bg)}

(* TODO: dangerous in a bind? use [Lwd_utils.local_state] instead? *)
let last_z = ref 0

let overlay ?dx:(o_x=0) ?dy:(o_y=0)
?handler:(o_h=fun ~x:_ ~y:_ _ -> `Unhandled)
?origin:(o_origin=Gravity.bottom_left)
?direction:(o_direction=Gravity.bottom_right)
=
let o_z = incr last_z; !last_z in
fun o_n ->
let desc = Overlay { o_n; o_x; o_y; o_h; o_z; o_origin; o_direction } in
{ w = 0; sw = 0; h = 0; sh = 0; desc; focus = Focus.empty; cache }

let event_filter ?focus f t : t =
let focus = match focus with
| None -> t.focus
@@ -275,19 +293,25 @@ struct
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);
focus = Focus.merge a.focus b.focus; desc = X (a, b); cache
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);
focus = Focus.merge a.focus b.focus; desc = Y (a, b); cache;
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);
focus = Focus.merge a.focus b.focus; desc = Z (a, b); cache;
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)
@@ -309,6 +333,10 @@ struct
| 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)
@@ -321,22 +349,16 @@ struct
Format.fprintf ppf "Scroll_area (@[%a,@ _@])" pp n
| Event_filter (n, _) ->
Format.fprintf ppf "Event_filter (@[%a,@ _@])" pp n
| Overlay o -> Format.fprintf ppf "Overlay (@[%a,@ _@])" pp_overlay o
| 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

and pp_overlay ppf r =
Format.fprintf ppf
"{@[o_n=%a;@ o_h=%s;@ o_h=%d;@ o_x=%d;@ o_y=%d;@ \
o_origin=%a;@ o_direction=%a@]}" pp r.o_n "_" r.o_x r.o_y r.o_z
Gravity.pp r.o_origin Gravity.pp r.o_direction

let iter f ui = match ui.desc with
| Atom _ -> ()
| Size_sensor (u, _) | Resize (u, _, _) | Mouse_handler (u, _)
| Size_sensor (u, _) | Transient_sensor (u, _) | Permanent_sensor (u, _)
| Resize (u, _, _) | Mouse_handler (u, _)
| Focus_area (u, _) | Scroll_area (u, _, _) | Event_filter (u, _)
| Overlay {o_n = u; _} -> f u
-> f u
| X (u1, u2) | Y (u1, u2) | Z (u1, u2) -> f u1; f u2
end
type ui = Ui.t
@@ -351,7 +373,7 @@ struct
type t = {
mutable size : size;
mutable view : ui;
mutable mouse_grab : (int * int * grab_function) option;
mutable mouse_grab : grab_function option;
}

let make () = {
@@ -372,19 +394,6 @@ struct
in
aux ui

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_focus ui

let sort_overlays o = List.sort
(fun o1 o2 -> - compare o1.o_z o2.o_z) o

let split ~a ~sa ~b ~sb total =
let stretch = sa + sb in
let flex = total - a - b in
@@ -410,12 +419,72 @@ struct
| `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 -> false
| Some (ox', oy', sw', sh') ->
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
| Scroll_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 (ox, oy, f); true
| `Grab f -> st.mouse_grab <- Some f; true
in
let rec aux ox oy sw sh t =
match t.desc with
@@ -439,8 +508,8 @@ struct
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, _) ->
aux ox oy sw sh desc
| Size_sensor (desc, _)
| Transient_sensor (desc, _) | Permanent_sensor (desc, _)
| Focus_area (desc, _) ->
aux ox oy sw sh desc
| Scroll_area (desc, sx, sy) ->
@@ -450,32 +519,20 @@ struct
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
| Overlay _ ->
false
| Event_filter (n, f) ->
begin match f (`Mouse (`Press btn, (x, y), [])) with
| `Handled -> true
| `Unhandled -> aux ox oy sw sh n
end
in
let rec overlays ox oy ovs =
List.exists (fun o ->
let ox = ox + o.o_x and oy = oy + o.o_y in
let ow = I.width o.o_n.cache.image in
let oh = I.height o.o_n.cache.image in
overlays ox oy o.o_n.cache.overlays
|| aux ox oy (ox + ow) (oy + oh) o.o_n
|| handle ox oy o.o_h
) (sort_overlays ovs)
in
overlays 0 0 t.cache.overlays || aux 0 0 w h t
aux 0 0 w h t

let release_grab st x y =
match st.mouse_grab with
| None -> ()
| Some (ox, oy, (_, release)) ->
| Some (_, release) ->
st.mouse_grab <- None;
release ~x:(x - ox) ~y:(y - oy)
release ~x ~y

let dispatch_mouse t (event, (x, y), _mods) =
if
@@ -487,15 +544,13 @@ struct
| `Drag ->
begin match t.mouse_grab with
| None -> false
| Some (ox, oy, (drag, _)) -> drag ~x:(x - ox) ~y:(y - oy); true
| Some (drag, _) -> drag ~x ~y; true
end
| `Release ->
release_grab t x y; true
then `Handled
else `Unhandled

let shift_o x y o = {o with o_x = o.o_x + x; o_y = o.o_y + y}

let resize_canvas rw rh image =
let w = I.width image in
let h = I.height image in
@@ -515,20 +570,23 @@ struct
let rec render_node vx1 vy1 vx2 vy2 sw sh t : cache =
if
let cache = t.cache in
vx1 >= cache.vx1 && vy1 >= cache.vy1 &&
vx2 <= cache.vx2 && vy2 <= cache.vy2 &&
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
{ vx1; vy1; vx2; vy2; image = I.void sw sh; overlays = [] }
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 ->
{ vx1 = 0; vy1 = 0; vx2 = sw; vy2 = sh;
overlays = [];
{ vx = Interval.make 0 sw;
vy = Interval.make 0 sh;
image = resize_canvas sw sh image }
| Size_sensor (desc, handler) ->
handler sw sh;
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
@@ -536,45 +594,44 @@ struct
let cache = render_node
(vx1 + sx) (vy1 + sy) (vx2 + sx) (vy2 + sy) (sx + sw) (sy + sh) t'
in
{ vx1; vx2; vy1; vy2;
overlays = (List.map (shift_o (-sx) (-sy)) cache.overlays);
image = resize_canvas sw sh (I.crop ~l:sx ~t:sy cache.image) }
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
{ vx1 = maxi ca.vx1 (cb.vx1 + aw);
vx2 = mini ca.vx2 (cb.vx2 + aw);
vy1 = maxi ca.vy1 cb.vy1;
vy2 = mini ca.vy2 cb.vy2;
overlays = List.map (shift_o aw 0) cb.overlays @ ca.overlays;
image = resize_canvas sw sh (I.(<|>) ca.image cb.image) }
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
{ vx1 = maxi ca.vx1 cb.vx1;
vx2 = mini ca.vx2 cb.vx2;
vy1 = maxi ca.vy1 (cb.vy1 + ah);
vy2 = mini ca.vy2 (cb.vy2 + ah);
overlays = List.map (shift_o 0 ah) cb.overlays @ ca.overlays;
image = resize_canvas sw sh (I.(<->) ca.image cb.image) }
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
{ vx1 = maxi ca.vx1 cb.vx1;
vx2 = mini ca.vx2 cb.vx2;
vy1 = maxi ca.vy1 cb.vy1;
vy2 = mini ca.vy2 cb.vy2;
overlays = cb.overlays @ ca.overlays;
image = resize_canvas sw sh (I.(</>) cb.image ca.image) }
| Overlay overlay ->
let ow = overlay.o_n.w and oh = overlay.o_n.h in
let c = render_node 0 0 ow oh ow oh overlay.o_n in
{ vx1; vx2; vy1; vy2;
overlays = overlay ::
List.map (shift_o overlay.o_x overlay.o_y) c.overlays;
image = resize_canvas sw sh I.empty }
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
@@ -589,30 +646,17 @@ struct
else
image
in
{ vx1 = c.vx1 + dx; vx2 = c.vx2 + dx;
vy1 = c.vy1 + dy; vy2 = c.vy2 + dy;
overlays = List.map (shift_o dx dy) c.overlays;
image
}
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 st =
let flatten (im,todo) o =
let todo = List.map (shift_o o.o_x o.o_y) o.o_n.cache.overlays @ todo in
let ovi = I.pad ~l:o.o_x ~t:o.o_y o.o_n.cache.image in
(I.(</>) ovi im, todo)
in
let rec process = function
| (im, []) -> im
| (im, ovs) -> process (List.fold_left flatten (im, []) ovs)
in
let (w, h) = st.size in
let cache = render_node 0 0 w h w h st.view in
process (cache.image, cache.overlays)
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] =
@@ -620,7 +664,7 @@ struct
| [] -> `Unhandled
| ui :: tl ->
begin match ui.desc with
| Atom _ | Overlay _ -> iter tl
| Atom _ -> iter tl
| X (a, b) | Y (a, b) | Z (a, b) ->
(* Try left/top most branch first *)
let st' =
@@ -638,6 +682,7 @@ struct
| `Unhandled -> iter tl
end
| Mouse_handler (t, _) | Size_sensor (t, _)
| Transient_sensor (t, _) | Permanent_sensor (t, _)
| Scroll_area (t, _, _) | Resize (t, _, _) ->
iter (t :: tl)
| Event_filter (t, f) ->
@@ -662,8 +707,9 @@ struct

let rec dispatch_focus t dir =
match t.desc with
| Atom _ | Overlay _ -> false
| Atom _ -> false
| Mouse_handler (t, _) | Size_sensor (t, _)
| Transient_sensor (t, _) | Permanent_sensor (t, _)
| Scroll_area (t, _, _) | Resize (t, _, _) | Event_filter (t, _) ->
dispatch_focus t dir
| Focus_area (t', _) ->


+ 8
- 5
lib/nottui/nottui.mli View File

@@ -67,14 +67,17 @@ sig
val has_focus : t -> bool
val keyboard_area : ?focus:Focus.status -> (key -> may_handle) -> t -> t
val scroll_area : int -> int -> t -> t
val size_sensor : (int -> int -> unit) -> t -> t

type size_sensor = w:int -> h:int -> unit
val size_sensor : size_sensor -> t -> t

type frame_sensor = x:int -> y:int -> w:int -> h:int -> unit -> unit
val transient_sensor : frame_sensor -> t -> t
val permanent_sensor : frame_sensor -> t -> t

val resize :
?w:int -> ?h:int -> ?sw:int -> ?sh:int ->
?fill:Gravity.t -> ?crop:Gravity.t -> ?bg:attr -> t -> t
val overlay :
?dx:int -> ?dy:int ->
?handler:mouse_handler -> ?origin:gravity -> ?direction:gravity ->
t -> t
val event_filter :
?focus:Focus.status ->
([`Key of key | `Mouse of mouse] -> may_handle) -> t -> t


+ 25
- 0
nottui-pretty.opam View File

@@ -0,0 +1,25 @@
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "A pretty-printer based on PPrint rendering UIs"
description: "TODO"
maintainer: ["fred@tarides.com"]
authors: ["Frédéric Bour"]
license: "MIT"
homepage: "https://github.com/let-def/lwd"
bug-reports: "https://github.com/let-def/lwd/issues"
depends: ["dune" "notty" "lwt" "nottui"]
build: [
["dune" "subst"] {pinned}
[
"dune"
"build"
"-p"
name
"-j"
jobs
"@install"
"@runtest" {with-test}
"@doc" {with-doc}
]
]
dev-repo: "git+https://github.com/let-def/lwd.git"

Loading…
Cancel
Save