Compare commits

...

26 Commits

Author SHA1 Message Date
  Frédéric Bour fa091a3d1f document, complete tyxml interface 2 months ago
  Frédéric Bour 7b03af8a2d document nottui 2 months ago
  Frédéric Bour a9095faa6f updating doc 2 months ago
  Frédéric Bour 1067a65207 some Lwd_seq combinators 2 months ago
  Frédéric Bour addb56401d tyxml: unify element and element list 3 months ago
  Frédéric Bour da494a2613 lwd_seq: optimize pure case 3 months ago
  Frédéric Bour ebd0d5c446 lwd_seq 3 months ago
  Drup 58fd8c6b85 WIP tyxml lwd 3 months ago
  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
29 changed files with 2008 additions and 346 deletions
Split View
  1. +9
    -0
      Makefile
  2. +1
    -21
      README.md
  3. +12
    -0
      dune-project
  4. +6
    -0
      examples/dune
  5. +14
    -6
      examples/minimal.ml
  6. +75
    -0
      examples/pretty.ml
  7. +4
    -0
      lib/lwd/lwd.ml
  8. +1
    -0
      lib/lwd/lwd.mli
  9. +8
    -0
      lib/lwd/lwd_infix_letop.mli
  10. +94
    -13
      lib/lwd/lwd_seq.ml
  11. +84
    -36
      lib/lwd/lwd_seq.mli
  12. +74
    -1
      lib/lwd/lwd_table.mli
  13. +5
    -17
      lib/lwd/lwd_utils.ml
  14. +28
    -2
      lib/lwd/lwd_utils.mli
  15. +7
    -0
      lib/nottui-lwt/nottui_lwt.mli
  16. +3
    -0
      lib/nottui-pretty/dune
  17. +390
    -0
      lib/nottui-pretty/nottui_pretty.ml
  18. +57
    -0
      lib/nottui-pretty/nottui_pretty.mli
  19. +177
    -52
      lib/nottui-widgets/nottui_widgets.ml
  20. +93
    -0
      lib/nottui-widgets/nottui_widgets.mli
  21. +214
    -168
      lib/nottui/nottui.ml
  22. +266
    -30
      lib/nottui/nottui.mli
  23. +2
    -0
      lib/tyxml-lwd/Makefile
  24. +7
    -0
      lib/tyxml-lwd/dune
  25. +31
    -0
      lib/tyxml-lwd/lwdom.ml
  26. +32
    -0
      lib/tyxml-lwd/lwdom.mli
  27. +264
    -0
      lib/tyxml-lwd/tyxml_lwd.ml
  28. +25
    -0
      nottui-pretty.opam
  29. +25
    -0
      tyxml-lwd.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



+ 1
- 21
README.md View File

@@ -90,26 +90,6 @@ Here `Lwd.map : ('a -> 'b) -> 'a Lwd.t -> 'b Lwd.t` apply a transformation to a

When the `Link` is triggered, the counter is incremented. Because `document` depends on the value of the counter it is invalidated.

#### Optional: abstracting local state

This pattern of having local state that you want to manipulate in an almost purely functional way is very common and has been abstracted in the `Lwd_utils` library.

Here is another way to implement our button example:

```ocaml
val Lwd_utils.local_state : ('a Lwd.t -> ('a -> unit) -> 'a * 'b) -> 'b

Lwd_utils.local_state (fun counter update ->
let initial_value = 0 in
let increment clicks () = update (clicks + 1) in
let button clicks =
Link (increment clicks,
Text ("Clicked " ^ string_of_int clicks ^ " times"))
in
initial_value, Lwd.map button counter
)
```

### Building computation graph

`Lwd.t` implements a few abstractions that should be familiar to seasoned functional programmers:
@@ -215,4 +195,4 @@ The first question can be answered positively with a naive encoding: put `Lwd.va

To answer the second question, it is interesting to observe that there is no concept of "diffing" here. _Lwd_ does not try to see if things have changed in order to update them. Rather, if an input change, the whole branch that depends on it is recomputed.

While this might lead to inefficient recomputations. ...TODO...
While this might lead to inefficient recomputations. ...TODO...

+ 12
- 0
dune-project View File

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

(package
(name tyxml-lwd)
(synopsis "Hello")
(description "TODO")
(depends dune lwd tyxml js_of_ocaml))

(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*)



+ 75
- 0
examples/pretty.ml View File

@@ -0,0 +1,75 @@
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 @@ Ui.vcat (
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 ~h:_ -> 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)
)

+ 4
- 0
lib/lwd/lwd.ml View File

@@ -73,6 +73,10 @@ let impure x = inj (
| other -> other
)

let is_pure x = match prj x with
| Pure x -> Some x
| _ -> None

let dummy = Pure (Any.any ())

let operator desc =


+ 1
- 0
lib/lwd/lwd.mli View File

@@ -46,6 +46,7 @@ val pair : 'a t -> 'b t -> ('a * 'b) t
(** [pair a b] is [map2 (fun x y->x,y) a b] *)

val impure : 'a t -> 'a t
val is_pure : 'a t -> 'a option

type 'a var
(** The workhorse of Lwd: a mutable variable that also tracks dependencies.


+ 8
- 0
lib/lwd/lwd_infix_letop.mli View File

@@ -1,6 +1,14 @@
val (let$) : 'a Lwd.t -> ('a -> 'b) -> 'b Lwd.t
(** Alias to {!Lwd.map'} suitable for let-op bindings *)

val (let$*) : 'a Lwd.t -> ('a -> 'b Lwd.t) -> 'b Lwd.t
(** Alias to {!Lwd.bind} suitable for let-op bindings *)

val (and$) : 'a Lwd.t -> 'b Lwd.t -> ('a * 'b) Lwd.t
(** Alias to {!Lwd.pair} suitable for let-op bindings *)

val ($=) : 'a Lwd.var -> 'a -> unit
(** Infix alias to {!Lwd.set} *)

val ($<-) : 'a Lwd_table.row -> 'a -> unit
(** Infix alias to {!Lwd_table.set} *)

+ 94
- 13
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
@@ -442,24 +448,95 @@ end

(* Lwd interface *)

let rec pure_map_reduce map reduce = function
| Nil -> assert false
| Leaf t -> map t.v
| Join t ->
reduce
(pure_map_reduce map reduce t.l)
(pure_map_reduce map reduce t.r)

let fold ~map ~reduce seq =
let reducer = ref (Reducer.make ~map ~reduce) in
Lwd.map' seq @@ fun seq ->
let reducer' = Reducer.update !reducer seq in
reducer := reducer';
Reducer.reduce reducer'
match Lwd.is_pure seq with
| Some Nil -> Lwd.pure None
| Some other -> Lwd.pure (Some (pure_map_reduce map reduce other))
| None ->
let reducer = ref (Reducer.make ~map ~reduce) in
Lwd.map' seq @@ fun seq ->
let reducer' = Reducer.update !reducer seq in
reducer := reducer';
Reducer.reduce reducer'

let fold_monoid map (zero, reduce) seq =
let reducer = ref (Reducer.make ~map ~reduce) in
Lwd.map' seq @@ fun seq ->
let reducer' = Reducer.update !reducer seq in
reducer := reducer';
match Reducer.reduce reducer' with
| None -> zero
| Some x -> x
match Lwd.is_pure seq with
| Some Nil -> Lwd.pure zero
| Some other -> Lwd.pure (pure_map_reduce map reduce other)
| None ->
let reducer = ref (Reducer.make ~map ~reduce) in
Lwd.map' seq @@ fun seq ->
let reducer' = Reducer.update !reducer seq in
reducer := reducer';
match Reducer.reduce reducer' with
| None -> zero
| Some x -> x

let monoid = (empty, concat)

let transform_list ls f =
Lwd_utils.map_reduce f monoid ls

let of_list ls = transform_list ls element

let rec of_sub_array f arr i j =
if j < i then empty
else if j = i then f arr.(i)
else
let k = i + (j - i) / 2 in
concat (of_sub_array f arr i k) (of_sub_array f arr (k + 1) j)

let transform_array arr f = of_sub_array f arr 0 (Array.length arr - 1)

let of_array arr = transform_array arr element

let to_list x =
let rec fold x acc = match x with
| Nil -> acc
| Leaf t -> t.v :: acc
| Join t -> fold t.l (fold t.r acc)
in
fold x []

let to_array x =
let rec count = function
| Nil -> 0
| Leaf _ -> 1
| Join t -> count t.l + count t.r
in
match count x with
| 0 -> [||]
| n ->
let rec first = function
| Nil -> assert false
| Leaf t -> t.v
| Join t -> first t.l
in
let first = first x in
let arr = Array.make n first in
let rec fold i = function
| Nil -> i
| Leaf t -> arr.(i) <- t.v; i + 1
| Join t ->
let i = fold i t.l in
let i = fold i t.r in
i
in
let _ : int = fold 0 x in
arr

let lwd_empty : 'a t Lwd.t = Lwd.pure Nil
let lwd_monoid : 'a. 'a t Lwd.t Lwd_utils.monoid =
(lwd_empty, fun x y -> Lwd.map2 concat x y)

let map f seq =
fold_monoid (fun x -> element (f x)) monoid seq

@@ -474,4 +551,8 @@ let filter_map f seq =
fold_monoid select monoid seq

let lift (seq : 'a Lwd.t seq Lwd.t) : 'a seq Lwd.t =
Lwd.join (fold_monoid (Lwd.map element) (Lwd_utils.lift_monoid monoid) seq)
Lwd.join (fold_monoid (Lwd.map element) lwd_monoid seq)

let bind (seq : 'a seq Lwd.t) (f : 'a -> 'b seq) : 'b seq Lwd.t =
fold_monoid f monoid seq


+ 84
- 36
lib/lwd/lwd_seq.mli View File

@@ -1,42 +1,46 @@
(* Sequence construction
(** {0 Sequence manipulation}

[Lwd_seq] implements a type of ordered collections with a pure interface.
In addition, changes to collections are easy to track.
[Lwd_seq] is an ordered collection with a pure interface.
Changes to collections are easy to track.

A collection can be transformed with the usual map, filter and fold
combinators. If later, the transformation is applied again to an updated
collection, shared elements (in the sense of physical sharing), the
result of the previous transformation will be reused for these elements.
A collection can be transformed with the usual map, filter and fold
combinators. If the collection is updated, shared elements (in the sense of
physical sharing), the result of the previous transformation will be reused
for these elements.

The book-keeping overhead is O(n) in the number of changes, so O(1) per
element.
The book-keeping overhead is O(n) in the number of changes, so O(1) per
element.
*)

type +'a t
type +'a seq = 'a t
(** The type of sequences *)

(** {1 Primitive constructors} *)

(* A sequence with no element. *)
val empty : 'a seq
(** A sequence with no element. *)

(* A singleton sequence. The physical identity of the element is considered
when reusing previous computations.
val element : 'a -> 'a seq
(** A singleton sequence. The physical identity of the element is considered
when reusing previous computations.

If you do:
let x1 = element x
let x2 = element x
If you do:

Then x1 and x2 are seen as different elements and no sharing will be done
during transformation.
*)
val element : 'a -> 'a seq
{[let x1 = element x
let x2 = element x]}

(* Concatenate two sequences into a bigger one.
As for [element], the physical identity of a sequence is considered for
reuse.
Then [x1] and [x2] are seen as different elements and no sharing will be
done during transformation.
*)

val concat : 'a seq -> 'a seq -> 'a seq
(** Concatenate two sequences into a bigger one.
As for [element], the physical identity of a sequence is considered for
reuse.
*)

(* Look at the contents of a sequence *)
(** {1 Looking at sequence contents} *)

type ('a, 'b) view =
| Empty
@@ -44,18 +48,44 @@ type ('a, 'b) view =
| Concat of 'b * 'b

val view : 'a seq -> ('a, 'a seq) view
(** View how a sequence is defined *)

(** {1 Conversion between sequences, lists and arrays} *)

val transform_list : 'a list -> ('a -> 'b seq) -> 'b seq
(** Produce a sequence by transforming each element of a list and concatenating
all results. *)

val transform_array : 'a array -> ('a -> 'b seq) -> 'b seq
(** Produce a sequence by transforming each element of an array and
concatenating all results. *)

val of_list : 'a list -> 'a seq
(** Produce a sequence from a list *)

val of_array : 'a array -> 'a seq
(** Produce a sequence from an array *)

val to_list : 'a seq -> 'a list
(** Produce a list from a sequence *)

val to_array : 'a seq -> 'a array
(** Produce an array from a sequence *)

(** {1 Balanced variant of sequences *)

module Balanced : sig
(* A variant of the sequence type that guarantees that the depth of
transformation, as measured in the number of [concat] nodes, grows in
O(log n) where n is the number of elements in the sequnce.

(** A variant of the sequence type that guarantees that the depth of a
transformation, measured as the number of nested [concat] nodes, grows in
O(log n) where n is the number of elements in the sequnce.

This is useful to prevent stack overflows and to avoid degenerate cases
where a single element change, but it is at the end of a linear sequence
where a single element changes, but it is at the end of a linear sequence
of [concat] nodes, thus making the total work O(n).
For instance, in:

[concat e1 (concat e2 (concat e3 (... (concat e_n))...))]
{[concat e1 (concat e2 (concat e3 (... (concat e_n))...))]}

If [e_n] changes, the whole spine has to be recomputed.

@@ -67,7 +97,10 @@ module Balanced : sig
only useful to balance the first sequence of the pipeline. Derived
sequence will have a depth bounded by the depth of the first one.
*)

type 'a t = private 'a seq
(** Type of balanced sequences *)

val empty : 'a t
val element : 'a -> 'a t
val concat : 'a t -> 'a t -> 'a t
@@ -75,36 +108,51 @@ module Balanced : sig
val view : 'a t -> ('a, 'a t) view
end

(* Lwd interface.
(** {1 Transforming sequences} *)

(**
All sequences live in [Lwd] monad: if a sequence changes slightly, parts
that have not changed will not be re-transformed.
*)

(* [fold ~map ~reduce] transforms a sequence.
If the sequence is non-empty, the [map] function is applied to element nodes
and the [reduce] function is used to combine transformed concatenated nodes.
If the sequence is empty, None is returned.
*)
val fold :
map:('a -> 'b) -> reduce:('b -> 'b -> 'b) -> 'a seq Lwd.t -> 'b option Lwd.t
(** [fold ~map ~reduce] transforms a sequence.
If the sequence is non-empty, the [map] function is applied to element
nodes and the [reduce] function is used to combine transformed concatenated
nodes.
If the sequence is empty, None is returned.
*)

val fold_monoid :
('a -> 'b) -> 'b Lwd_utils.monoid -> 'a seq Lwd.t -> 'b Lwd.t
(** Like [fold], but reduction and default value are defined by a [monoid] *)

(* [map f] transforms a sequence by applying [f] to each element. *)
val map :
('a -> 'b) -> 'a seq Lwd.t -> 'b seq Lwd.t
(** [map f] transforms a sequence by applying [f] to each element. *)

val filter :
('a -> bool) -> 'a seq Lwd.t -> 'a seq Lwd.t
(** [filter p] transforms a sequence by keeping elements that satisfies [p]. *)

val filter_map :
('a -> 'b option) -> 'a seq Lwd.t -> 'b seq Lwd.t
(** Filter and map elements at the same time *)

val lift : 'a Lwd.t seq Lwd.t -> 'a seq Lwd.t
(** Remove a layer of [Lwd] inside a sequence. *)

val bind : 'a seq Lwd.t -> ('a -> 'b seq) -> 'b seq Lwd.t
(** Sequence forms a monad too... *)

val monoid : 'a t Lwd_utils.monoid
(** Monoid instance for sequences *)

val lwd_monoid : 'a t Lwd.t Lwd_utils.monoid
(** Monoid instance for reactive sequences *)

(* Low-level interface *)
(** {1 Low-level interface for observing changes} *)

module Reducer : sig
(* The interface allows to implement incremental sequence transformation


+ 74
- 1
lib/lwd/lwd_table.mli View File

@@ -1,29 +1,102 @@
(** {0 Table manipulation}

[Lwd_table] is an ordered collection with an impure interface.
It is designed to be efficient in an interactive setting.

The interface mimics the one of a doubly-linked lists: from a node, called
row, you can iterate backward and forward, insert and delete other nodes,
and change the value it is bound to.

The sequence of nodes can be observed by map/reduce operations, that will
be recomputed efficiently when sequence changes.
*)

type 'a t
type 'a row
(** The type of tables *)

val make : unit -> 'a t
val clear : 'a t -> unit
(** Create a new table *)

(** {1 Inserting rows} *)

val prepend : ?set:'a -> 'a t -> 'a row
(** Insert and return a new row at the start of a table.
It can be optionnally initialized to the value of [set]. *)

val append : ?set:'a -> 'a t -> 'a row
(** Insert and return a new row at the end of a table.
It can be optionnally initialized to the value of [set]. *)

val prepend' : 'a t -> 'a -> unit
(* Insert a new initialized row at start of a table *)

val append' : 'a t -> 'a -> unit
(* Insert a new initialized row at end of a table *)

val before : ?set:'a -> 'a row -> 'a row
(** Insert and return a new row just before an existing row.
It can be optionnally initialized to the value of [set].

If the input row is unbound ([is_bound] returns false), the returned row is
too.
*)

val after : ?set:'a -> 'a row -> 'a row
(** Insert and return a new row just after an existing row.
It can be optionnally initialized to the value of [set].

If the input row is unbound ([is_bound] returns false), the returned row is
too.
*)

(** {1 Iterating over rows} *)

val first : 'a t -> 'a row option
(** Returns the first row of a table, or [None] if the table is empty *)

val last : 'a t -> 'a row option
(** Returns the last row of a table, or [None] if the table is empty *)

val next : 'a row -> 'a row option
(** Returns the row next to another one, or [None] if the input row is unbound
or is the last row *)

val prev : 'a row -> 'a row option
(** Returns the row just before another one, or [None] if the input row is
unbound or is the first row *)

(** {1 Accessing and changing row contents} *)

val get : 'a row -> 'a option
(** Get the value associated with a row, if any, or [None] if the row is
unbound *)

val set : 'a row -> 'a -> unit
(** Set the value associated with a row, or do nothing if the row is unbound *)

val unset : 'a row -> unit
(** Unset the value associated with a row *)

(** {1 Removing rows} *)

val is_bound : 'a row -> bool
(** Returns [true] iff the row is bound in a table (it has not beem [remove]d
yet, the table has not been [clear]ed) *)

val remove : 'a row -> unit
(** [remove] a row from its table, [is_bound] will be [true] after that *)

val clear : 'a t -> unit
(** Remove all rows from a table *)

(** {1 Observing table contents} *)

val reduce : 'a Lwd_utils.monoid -> 'a t -> 'a Lwd.t
(** Observe the content of a table by reducing it with a monoid *)

val map_reduce : ('a row -> 'a -> 'b) -> 'b Lwd_utils.monoid -> 'a t -> 'b Lwd.t
(** Observe the content of a table by mapping and reducing it *)

val iter : ('a -> unit) -> 'a t -> unit
(** Immediate, non reactive, iteration over elements of a table *)

+ 5
- 17
lib/lwd/lwd_utils.ml View File

@@ -4,18 +4,21 @@ type 'a monoid = 'a * ('a -> 'a -> 'a)
let lift_monoid (zero, plus) =
(Lwd.return zero, Lwd.map2 plus)

let pure_pack (zero, plus) items =
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
match List.fold_left (cons_monoid 0) [] items with
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' ->
@@ -34,21 +37,6 @@ let pack_seq (zero, plus) items =
| (_,x) :: xs ->
List.fold_left (fun acc (_, v) -> Lwd.map2 plus v acc) x xs

let local_state f =
let r = ref None in
let acquire () = match !r with
| None -> invalid_arg "Lwd_utils.trace: cyclic evaluation"
| Some v -> v
in
let prim = Lwd.prim ~acquire ~release:ignore in
let update v =
r := Some v;
Lwd.invalidate prim
in
let v, result = f (Lwd.get_prim prim) update in
r := Some v;
result

let rec map_l (f:'a -> 'b Lwd.t) (l:'a list) : 'b list Lwd.t =
match l with
| [] -> Lwd.return []


+ 28
- 2
lib/lwd/lwd_utils.mli View File

@@ -1,12 +1,38 @@
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
val pure_pack : 'a monoid -> 'a list -> 'a
(** 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 **)

val local_state : ('a Lwd.t -> ('a -> unit) -> 'a * 'b) -> 'b
(** {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] *)

+ 7
- 0
lib/nottui-lwt/nottui_lwt.mli View File

@@ -7,7 +7,14 @@ type event = [
| `Paste of Unescape.paste
| `Resize of int * int
]
(** FIXME: Refactor to use [Nottui.Ui.event]? *)

val render : ?quit:unit Lwt.t -> size:int * int -> event Lwt_stream.t -> ui Lwd.t -> image Lwt_stream.t
(** Turn a stream of events into a stream of images. *)

val run : (*?term:Term.t ->*) ?quit:unit Lwt.t -> ui Lwd.t -> unit Lwt.t
(** Run mainloop in [Lwt], until the [quit] promise is fulfilled.

The ui is a normal [Lwd.t] value, but events are free to spawn asynchronous
[Lwt] threads.
*)

+ 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.space 1 0 in
function
| 0 -> Ui.empty
| 1 -> space
| n -> Ui.space 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.space 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

+ 177
- 52
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.space 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

@@ -93,9 +95,9 @@ let vscroll_area ~state ~change t =
in
Lwd.map2' t state @@ fun t state ->
t
|> Ui.scroll_area 0 state.position
|> Ui.shift_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)
@@ -138,7 +140,7 @@ let scroll_area ?(offset=0,0) t =
in
Lwd.map2' t (Lwd.get offset) @@ fun t (s_x, s_y) ->
t
|> Ui.scroll_area s_x s_y
|> Ui.shift_area s_x s_y
|> Ui.mouse_area scroll_handler
|> Ui.keyboard_area focus_handler

@@ -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
@@ -486,7 +556,7 @@ let rec iterate n f x =
@param bg attribute for controlling background style
@param h_space horizontal space between each cell in a row
@param v_space vertical space between each row
@param fill used to control filling of cells
@param pad used to control padding of cells
@param crop used to control cropping of cells
TODO: control padding/alignment, vertically and horizontally
TODO: control align left/right in cells
@@ -494,7 +564,7 @@ let rec iterate n f x =
TODO: headers *)
let grid
?max_h ?max_w
?fill ?crop ?bg
?pad ?crop ?bg
?(h_space=0)
?(v_space=0)
?(headers:Ui.t Lwd.t list option)
@@ -527,10 +597,10 @@ let grid
(* now render, with some padding *)
let pack_pad_x =
if h_space<=0 then (Ui.empty, Ui.join_x)
else (Ui.empty, (fun x y -> Ui.hcat [x; Ui.void h_space 0; y]))
else (Ui.empty, (fun x y -> Ui.hcat [x; Ui.space h_space 0; y]))
and pack_pad_y =
if v_space =0 then (Ui.empty, Ui.join_y)
else (Ui.empty, (fun x y -> Ui.vcat [x; Ui.void v_space 0; y]))
else (Ui.empty, (fun x y -> Ui.vcat [x; Ui.space v_space 0; y]))
in
let rows =
List.map
@@ -545,16 +615,71 @@ let grid
let row =
List.mapi
(fun i c ->
Ui.resize ~w:col_widths.(i) ~h:row_h ?crop ?fill ?bg c)
Ui.resize ~w:col_widths.(i) ~h:row_h ?crop ?pad ?bg c)
row
in
Lwd_utils.pure_pack pack_pad_x row)
Lwd_utils.reduce pack_pad_x row)
rows
in
(* TODO: mouse and keyboard handling *)
let ui = Lwd_utils.pure_pack pack_pad_y rows in
let ui = Lwd_utils.reduce pack_pad_y rows in
Lwd.return ui

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'


+ 93
- 0
lib/nottui-widgets/nottui_widgets.mli View File

@@ -0,0 +1,93 @@
open Notty
open Nottui

val empty_lwd : ui Lwd.t

(* Primitive printing *)

val string : ?attr:attr -> string -> ui
val int : ?attr:attr -> int -> ui
val bool : ?attr:attr -> bool -> ui
val float_ : ?attr:attr -> float -> ui

(* Printf support *)
val printf : ?attr:attr -> ('a, unit, string, ui) format4 -> 'a
val kprintf : (ui -> 'a) -> ?attr:attr -> ('b, unit, string, 'a) format4 -> 'b

val fmt : ?attr:attr -> ('a, Format.formatter, unit, ui) format4 -> 'a
val kfmt : (ui -> 'a) -> ?attr:attr -> ('b, Format.formatter, unit, 'a) format4 -> 'b

(* FIXME Menu *)
(*val menu_overlay : ?dx:'a -> ?dy:'b -> 'c -> 'd -> 'e*)
val main_menu_item : string -> (unit -> 'a) -> ui Lwd.t
val sub_menu_item : string -> (unit -> 'a) -> ui Lwd.t
val sub_entry : string -> (unit -> unit) -> ui

(* FIXME Explain how scrolling works *)
val scroll_step : int
type scroll_state = { position : int; bound : int; visible : int; total : int }
val default_scroll_state : scroll_state
val vscroll_area :
state:scroll_state Lwd.t ->
change:([> `Action | `Content ] -> scroll_state -> unit) ->
ui Lwd.t -> ui Lwd.t

val scroll_area :
?offset:int * int -> ui Lwd.t -> ui Lwd.t

(* FIXME Explain panes *)
val v_pane : ui Lwd.t -> ui Lwd.t -> ui Lwd.t
val h_pane : ui Lwd.t -> ui Lwd.t -> ui Lwd.t

(* FIXME Edit field *)

val edit_field :
?focus:Focus.handle ->
(string * int) Lwd.t ->
on_change:(string * int -> unit) ->
on_submit:(string * int -> unit) -> ui Lwd.t

(* FIXME Tabs *)

val tabs : (string * (unit -> ui Lwd.t)) list -> ui Lwd.t

(* FIXME Flex box *)

val flex_box : ?w:int Lwd.t -> ui Lwd.t list -> ui Lwd.t

(* FIXME Unfoldable *)

val unfoldable :
?folded_by_default:bool ->
ui Lwd.t -> (unit -> ui Lwd.t) -> ui Lwd.t

(* FIXME Boxes *)
val hbox : ui Lwd.t list -> ui Lwd.t
val vbox : ui Lwd.t list -> ui Lwd.t
val zbox : ui Lwd.t list -> ui Lwd.t

(* FIXME List *)
val vlist : ?bullet:string -> ui Lwd.t list -> ui Lwd.t

val vlist_with :
?bullet:string ->
?filter:('a -> bool) Lwd.t ->
('a -> ui Lwd.t) -> 'a list Lwd.t -> ui Lwd.t

val grid :
?max_h:int -> ?max_w:int ->
?pad:gravity -> ?crop:gravity -> ?bg:attr ->
?h_space:int -> ?v_space:int ->
?headers:ui Lwd.t list ->
ui Lwd.t list list -> ui Lwd.t

val button : ?attr:attr -> string -> (unit -> unit) -> ui

val file_select :
?abs:bool ->
?filter:(String.t -> bool) ->
on_select:(string -> unit) -> unit -> ui Lwd.t

val toggle : ?init:bool -> string Lwd.t -> (bool -> unit) -> ui Lwd.t

val toggle' : string Lwd.t -> bool Lwd.var -> ui Lwd.t

+ 214
- 168
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)
| 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 }
@@ -210,20 +232,21 @@ 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)
let space x y = atom (I.void x y)

let mouse_area f t : t =
{ t with desc = Mouse_handler (t, f) }
@@ -235,36 +258,31 @@ struct
in
{ t with desc = Focus_area (t, f); focus }

let scroll_area x y t : t =
{ t with desc = Scroll_area (t, x, y) }
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 resize ?w ?h ?sw ?sh ?fill ?crop ?(bg=A.empty) t : t =
let g = match fill, crop with
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 ?pad ?crop ?(bg=A.empty) t : t =
let g = match pad, crop with
| None, None -> Gravity.(pair default default)
| Some g, None | None, Some g -> Gravity.(pair g g)
| Some fill, Some crop -> Gravity.(pair fill crop)
| Some pad, Some crop -> Gravity.(pair 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)}

(* 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,28 +293,34 @@ 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)
let pack_y = (empty, join_y)
let pack_z = (empty, join_z)

let hcat xs = Lwd_utils.pure_pack pack_x xs
let vcat xs = Lwd_utils.pure_pack pack_y xs
let zcat xs = Lwd_utils.pure_pack pack_z xs
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

@@ -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)
@@ -317,26 +345,20 @@ struct
Format.fprintf ppf "Mouse_handler (@[%a,@ _@])" pp n
| Focus_area (n, _) ->
Format.fprintf ppf "Focus_area (@[%a,@ _@])" pp n
| Scroll_area (n, _, _) ->
Format.fprintf ppf "Scroll_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
| 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, _)
| Focus_area (u, _) | Scroll_area (u, _, _) | Event_filter (u, _)
| Overlay {o_n = u; _} -> f u
| 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
@@ -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) ->