Compare commits

...

14 Commits

Author SHA1 Message Date
Frédéric Bour fa091a3d1f document, complete tyxml interface 2020-09-17 17:59:15 +02:00
Frédéric Bour 7b03af8a2d document nottui 2020-09-17 17:33:59 +02:00
Frédéric Bour a9095faa6f updating doc 2020-09-17 15:21:40 +02:00
Frédéric Bour 1067a65207 some Lwd_seq combinators 2020-09-17 13:43:38 +02:00
Frédéric Bour addb56401d tyxml: unify element and element list 2020-09-02 18:23:44 +02:00
Frédéric Bour da494a2613 lwd_seq: optimize pure case 2020-09-02 18:23:29 +02:00
Frédéric Bour ebd0d5c446 lwd_seq 2020-09-01 17:34:49 +02:00
Drup 58fd8c6b85 WIP tyxml lwd 2020-08-30 11:48:33 +02:00
Frédéric Bour bfc481aa54 WIP 2020-08-30 11:45:30 +02:00
Frédéric Bour a995047176 implement permanent sensors 2020-08-30 11:45:30 +02:00
Frédéric Bour b4447f82f3 wip 2020-08-30 11:45:30 +02:00
Frédéric Bour fe42d56bf5 full_sensor before/after 2020-08-30 11:45:30 +02:00
Frédéric Bour 9eb18e2207 Full_sensor trigger only once 2020-08-30 11:45:30 +02:00
Frédéric Bour 07823fed56 full-sensor 2020-08-30 11:45:30 +02:00
24 changed files with 1373 additions and 346 deletions

View File

@ -3,6 +3,9 @@ all:
TESTS=minimal misc reranger stress
$(TESTS):
dune build examples/$@.bc
run-minimal:
dune exec examples/minimal.bc
@ -18,6 +21,9 @@ run-stress:
run-pretty:
dune exec examples/pretty.bc
run-pretty-lambda:
dune exec examples/pretty_lambda.bc
run-stress.exe:
dune exec examples/stress.exe

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:

View File

@ -21,6 +21,12 @@
(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")

View File

@ -11,8 +11,7 @@ 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 (
Lwd.pure @@ Ui.vcat (
List.map
(fun choice ->
Nottui_widgets.sub_entry choice (fun () -> f choice))
@ -60,7 +59,7 @@ let varying_width f =
(f (Lwd.get width))
(fun ui ->
Nottui.Ui.size_sensor
(fun w _ -> if Lwd.peek width <> w then Lwd.set width w)
(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 =

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 =

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.

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

View File

@ -448,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
@ -480,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

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.
If you do:
let x1 = element x
let x2 = element x
Then x1 and x2 are seen as different elements and no sharing will be done
during transformation.
*)
val element : 'a -> 'a seq
(** A singleton sequence. The physical identity of the element is considered
when reusing previous computations.
(* Concatenate two sequences into a bigger one.
As for [element], the physical identity of a sequence is considered for
reuse.
If you do:
{[let x1 = element x
let x2 = element x]}
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
(* Look at the contents of a sequence *)
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.
*)
(** {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. *)
(* Low-level interface *)
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 *)
(** {1 Low-level interface for observing changes} *)
module Reducer : sig
(* The interface allows to implement incremental sequence transformation

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

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 []

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
val pack_seq : 'a monoid -> 'a Lwd.t Seq.t -> 'a Lwd.t
val pure_pack : 'a monoid -> 'a list -> 'a
(** Reduce a list of elements in [Lwd] monad *)
val local_state : ('a Lwd.t -> ('a -> unit) -> 'a * 'b) -> 'b
val pack_seq : 'a monoid -> 'a Lwd.t Seq.t -> 'a Lwd.t
(** Reduce an (OCaml) [Seq.t] with a monoid *)
val reduce : 'a monoid -> 'a list -> 'a
(** Reduce a list with a monoid **)
val map_reduce : ('a -> 'b) -> 'b monoid -> 'a list -> 'b
(** Map and reduce a list with a monoid **)
(** {1 Other Lwd list functions} *)
val map_l : ('a -> 'b Lwd.t) -> 'a list -> 'b list Lwd.t
val flatten_l : 'a Lwd.t list -> 'a list Lwd.t
(** Commute [Lwd] and [list] *)

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

View File

@ -194,11 +194,11 @@ open Nottui
(* Some intermediate UI *)
let blank_ui =
let space = Ui.atom (Notty.I.void 1 0) in
let space = Ui.space 1 0 in
function
| 0 -> Ui.empty
| 1 -> space
| n -> Ui.atom (Notty.I.void n 0)
| n -> Ui.space n 0
let flat_hardline =
Flat_span { prefix = Ui.empty; body = Ui.empty; suffix = Ui.empty; }
@ -207,7 +207,7 @@ 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
let pad = Ui.space indent 0 in
(Ui.join_x pad body, Ui.join_x pad suffix)
(* Flat renderer *)

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);
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
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
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
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 ()
)
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
@ -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,14 +615,14 @@ 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 =

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

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
type flags = int
let flags_none = 0
let flag_transient_sensor = 1
let flag_permanent_sensor = 2
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 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) ->
ui.desc <- t.desc;
let sensor = sensor ~x:ox ~y:oy ~w:sw ~h:sh in
update_sensors ox oy sw sh t;
sensor ()
| Permanent_sensor (t, sensor) ->
let sensor = sensor ~x:ox ~y:oy ~w:sw ~h:sh in
update_sensors ox oy sw sh t;
sensor ()
| Resize (t, g, _) ->
let open Gravity in
let dx, rw = pack ~fixed:t.w ~stretch:t.sw sw (h (p1 g)) (h (p2 g)) in
let dy, rh = pack ~fixed:t.h ~stretch:t.sh sh (v (p1 g)) (v (p2 g)) in
update_sensors (ox + dx) (oy + dy) rw rh t
| Shift_area (t, sx, sy) ->
update_sensors (ox - sx) (oy - sy) sw sh t
| X (a, b) ->
let aw, bw = split ~a:a.w ~sa:a.sw ~b:b.w ~sb:b.sw sw in
update_sensors ox oy aw sh a;
update_sensors (ox + aw) oy bw sh b
| Y (a, b) ->
let ah, bh = split ~a:a.h ~sa:a.sh ~b:b.h ~sb:b.sh sh in
update_sensors ox oy sw ah a;
update_sensors ox (oy + ah) sw bh b
| Z (a, b) ->
update_sensors ox oy sw sh a;
update_sensors ox oy sw sh b
)
let update_focus ui =
match ui.focus with
| Focus.Empty | Focus.Handle _ -> ()
| Focus.Conflict i -> solve_focus ui i
let update t size ui =
t.size <- size;
t.view <- ui;
update_sensors 0 0 (fst size) (snd size) ui;
update_focus ui
let dispatch_mouse st x y btn w h t =
let handle ox oy f =
match f ~x:(x - ox) ~y:(y - oy) btn with
| `Unhandled -> false
| `Handled -> true
| `Grab f -> st.mouse_grab <- Some (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,43 +508,31 @@ 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) ->
| Shift_area (desc, sx, sy) ->
aux (ox - sx) (oy - sy) sw sh desc
| Resize (t, g, _bg) ->
let open Gravity in
let dx, rw = pack ~fixed:t.w ~stretch:t.sw sw (h (p1 g)) (h (p2 g)) in
let dy, rh = pack ~fixed:t.h ~stretch:t.sh sh (v (p1 g)) (v (p2 g)) in
aux (ox + dx) (oy + dy) rw rh t
| 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,66 +570,68 @@ 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
| Scroll_area (t', sx, sy) ->
| Shift_area (t', sx, sy) ->
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,7 +682,8 @@ struct
| `Unhandled -> iter tl
end
| Mouse_handler (t, _) | Size_sensor (t, _)
| Scroll_area (t, _, _) | Resize (t, _, _) ->
| Transient_sensor (t, _) | Permanent_sensor (t, _)
| Shift_area (t, _, _) | Resize (t, _, _) ->
iter (t :: tl)
| Event_filter (t, f) ->
begin match f (`Key key) with
@ -662,9 +707,10 @@ struct
let rec dispatch_focus t dir =
match t.desc with
| Atom _ | Overlay _ -> false
| Atom _ -> false
| Mouse_handler (t, _) | Size_sensor (t, _)
| Scroll_area (t, _, _) | Resize (t, _, _) | Event_filter (t, _) ->
| Transient_sensor (t, _) | Permanent_sensor (t, _)
| Shift_area (t, _, _) | Resize (t, _, _) | Event_filter (t, _) ->
dispatch_focus t dir
| Focus_area (t', _) ->
if Focus.has_focus t'.focus then

View File

@ -1,43 +1,178 @@
open Notty
(**
Nottui augments Notty with primitives for laying out user interfaces (in the
terminal) and reacting to input events.
*)
(** {1 Focus (defining and managing active objects)} *)
module Focus :
sig
type handle
(** A [handle] represents a primitive area that can request, receive and lose
the focus. A visible UI is made of many handles, of which at most one can
be active. *)
val make : unit -> handle
(** Create a new handle *)
val request : handle -> unit
(** Request the focus *)
val release : handle -> unit
(** Release the focus (if the handle has it) *)
type status
(** [status] represents the state in which a handle can be.
Externally we care about having or not the focus, which can be queried
with the [has_focus] function. Internally, [status] also keeps track of
conflicts (if multiple handles [request]ed the focus).
*)
val empty : status
(** A status that has no focus and no conflicts *)
val status : handle -> status Lwd.t
(** Get the status of a focus [handle]. The [status] is a reactive value:
it will evolve over time, as focus is received or lost. *)
val has_focus : status -> bool
(** Check if this [status] corresponds to an active focus *)
(** TODO
This implements a more general concept of "reactive auction":
- multiple parties are competing for a single resource (focus here, but
for instance a tab component can only display a single tab among many).
- the result can evolve over time, parties can join or leave, or bid
"more".
*)
end
(** {1 Gravity (horizontal and vertical alignments)} *)
module Gravity :
sig
type direction = [
| `Negative
| `Neutral
| `Positive
]
(** A gravity is a pair of directions along the horizontal and vertical
axis.
Horizontal axis goes from left to right and vertical axis from top to
bottom.
[`Negative] direction means left / top bounds, [`Neutral] means center
and [`Positive] means right / bottom.
*)
val pp_direction : Format.formatter -> direction -> unit
(** Printing directions *)
type t
(** The gravity type is a pair of an horizontal and a vertical gravity *)
val pp : Format.formatter -> t -> unit
(** Printing gravities *)
val make : h:direction -> v:direction -> t
(** Make a gravity value from an [h]orizontal and a [v]ertical directions. *)
val default : t
(** Default (negative, aligning to the top-left) gravity. *)
val h : t -> direction
(** Get the horizontal direction *)
val v : t -> direction
(** Get the vertical direction *)
end
type gravity = Gravity.t
(** {1 Primitive combinators for making user interfaces} *)
module Ui :
sig
type t
(* Type of UI elements *)
val pp : Format.formatter -> t -> unit
(** Printing UI element *)
(** {1 Layout specifications} *)
type layout_spec = { w : int; h : int; sw : int; sh : int; }
(** The type of layout specifications.
For each axis, layout is specified as a pair of integers:
- a fixed part that is expressed as a number of columns or rows
- a stretchable part that represents a strength used to share the
remaining space (or 0 if the UI doesn't extend over free space)
*)
val pp_layout_spec : Format.formatter -> layout_spec -> unit
(** Printing layout specification *)
val layout_spec : t -> layout_spec
(** Get the layout spec for an UI element *)
val layout_width : t -> int
(** Get the layout width component of an UI element *)
val layout_stretch_width : t -> int
(** Get the layout stretch width strength of an UI element *)
val layout_height : t -> int
(** Get the layout height component of an UI element *)
val layout_stretch_height : t -> int
(** Get the layout height strength of an UI element *)
(** {1 Primitive images} *)
val empty : t
(** The empty surface: it occupies no space and does not do anything *)
val atom : image -> t
(** Primitive surface that displays a Notty image *)
val space : int -> int -> t
(** Void space of dimensions [x,y]. Useful for padding and interstitial
space. *)
(** {1 Event handles} *)
type may_handle = [ `Unhandled | `Handled ]
(** An event is propagated until it gets handled.
Handler functions return a value of type [may_handle] to indicate
whether the event was handled or not. *)
type mouse_handler = x:int -> y:int -> Unescape.button -> [
| may_handle
| `Grab of (x:int -> y:int -> unit) * (x:int -> y:int -> unit)
]
(** The type of handlers for mouse events. They receive the (absolute)
coordinates of the mouse, the button that was clicked.
In return they indicate whether the event was handled or if the mouse is
"grabbed".
When grabbed, two functions [on_move] and [on_release] should be
provided. The [on_move] function will be called when the mouse move while
the button is pressed and the [on_release] function is called when the
button is released.
During that time, no other mouse input events can be dispatched.
*)
type semantic_key = [
(* Clipboard *)
@ -46,83 +181,184 @@ sig
(* Focus management *)
| `Focus of [`Next | `Prev | `Left | `Right | `Up | `Down]
]
(** Key handlers normally reacts to keyboard input but a few special keys are
defined to represent higher-level actions.
Copy and paste, as well as focus movements. *)
type key = [
| Unescape.special | `Uchar of Uchar.t | `ASCII of char | semantic_key
] * Unescape.mods
(** A key is the pair of a main key and a list of modifiers *)
type mouse = Unescape.mouse
(** Specification of mouse inputs, taken from Notty *)
type event = [ `Key of key | `Mouse of mouse | `Paste of Unescape.paste ]
(* The type of input events. *)
type layout_spec = { w : int; h : int; sw : int; sh : int; }
val pp_layout_spec : Format.formatter -> layout_spec -> unit
type t
val pp : Format.formatter -> t -> unit
val empty : t
val atom : image -> t
val mouse_area : mouse_handler -> t -> t
val has_focus : t -> bool
(** Handle mouse events that happens over an ui. *)
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
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
(** Define a focus receiver, handle keyboard events over the focused area *)
val has_focus : t -> bool
(** Check if this UI has focus, either directly (it is a focused
[keyboard_area]), or inherited (one of the child is a focused
[keyboard_area]). *)
val event_filter :
?focus:Focus.status ->
([`Key of key | `Mouse of mouse] -> may_handle) -> t -> t
(** A hook that intercepts and can interrupt events when they reach a
sub-part of the UI. *)
(** {1 Sensors}
Sensors are used to observe the physical dimensions after layout has been
resolved.
*)
type size_sensor = w:int -> h:int -> unit
(** The size sensor callback tells you the [w]idth and [h]eight of UI.
The sensor is invoked only when the UI is visible. *)
val size_sensor : size_sensor -> t -> t
(** Attach a size sensor to an image *)
type frame_sensor = x:int -> y:int -> w:int -> h:int -> unit -> unit
(** The frame sensor callback gives you the whole rectangle where the widget
is displayed.
The first for components are applied during before visiting children,
the last unit is applied after visiting children.
*)
val transient_sensor : frame_sensor -> t -> t
(** Attach a transient frame sensor: the callback will be invoked only once,
on next frame. *)
val permanent_sensor : frame_sensor -> t -> t
(** Attach a permanent sensor: the callback will be invoked on every frame.
Note that this can have a significant impact on performance. *)
(** {1 Composite images} *)
val resize :
?w:int -> ?h:int -> ?sw:int -> ?sh:int ->
?pad:Gravity.t -> ?crop:Gravity.t -> ?bg:attr -> t -> t
(** Override the layout specification of an image with provided [w], [h],
[sw] or [sh].
[pad] and [crop] are used to determine how to align the UI when there is
too much or not enough space.
[bg] is used to fill the padded background.
*)
val shift_area : int -> int -> t -> t
(** Shift the contents of a UI by a certain amount.
Positive values crop the image while negative values pad.
This primitive is used to implement scrolling.
*)
val join_x : t -> t -> t
(** Horizontally join two images *)
val join_y : t -> t -> t
(** Vertically join two images *)
val join_z : t -> t -> t
(** Superpose two images. The right one will be on top. *)
val pack_x : t Lwd_utils.monoid
(** Horizontal concatenation monoid *)
val pack_y : t Lwd_utils.monoid
(** Vertical concatenation monoid *)
val pack_z : t Lwd_utils.monoid
(** Superposition monoid *)
val hcat : t list -> t
(** Short-hand for horizontally joining a list of images *)
val vcat : t list -> t
(** Short-hand for vertically joining a list of images *)
val zcat : t list -> t
val void : int -> int -> t
(** Void space of dimensions [x,y]. Useful for padding and interstitial
space. *)
val layout_spec : t -> layout_spec
val layout_width : t -> int
val layout_stretch_width : t -> int
val layout_height : t -> int
val layout_stretch_height : t -> int
(** Short-hand for superposing a list of images *)
end
type ui = Ui.t
(** {1 Rendering user interfaces and dispatching input events} *)
module Renderer :
sig
type size = int * int
type t
(** The type of a renderer *)
type size = int * int
(** Size of a rendering surface, as a pair of width and height *)
val make : unit -> t
val size : t -> size
(** Create a new renderer.
It maintains state to update output image and to dispatch events. *)
val update : t -> size -> Ui.t -> unit
(** Update the contents to be rendered to the given UI at a specific size *)
val size : t -> size
(** Get the size of the last update *)
val image : t -> image
(** Render and return actual image *)
val dispatch_mouse : t -> Ui.mouse -> Ui.may_handle
val dispatch_key : t -> Ui.key -> Ui.may_handle
(** Dispatch a mouse event *)
val dispatch_key : t -> Ui.key -> Ui.may_handle
(** Dispatch a keyboard event *)
val dispatch_event : t -> Ui.event -> Ui.may_handle
(** Dispatch an event *)
end
(** {1 Main loop}
Outputting an interface to a TTY and interacting with it
*)
module Ui_loop :
sig
open Notty_unix
val step : ?process_event:bool -> ?timeout:float -> renderer:Renderer.t ->
Term.t -> ui Lwd.root -> unit
(** Run one step of the main loop.
Update output image describe by the provided [root].
If [process_event], wait up to [timeout] seconds for an input event, then
consume and dispatch it. *)
val run :
?tick_period:float -> ?tick:(unit -> unit) ->
?term:Term.t -> ?renderer:Renderer.t ->
?quit:bool Lwd.var -> ui Lwd.t -> unit
(** Repeatedly run steps of the main loop, until either:
- [quit] becomes true,
- the ui computation raises an exception,
- if [quit] was not provided, wait for Ctrl-Q event
Specific [term] or [renderer] instances can be provided, otherwise new
ones will be allocated and released.
To simulate concurrency in a polling fashion, tick function and period
can be provided. Use the [Lwt] backend for real concurrency.
*)
end

2
lib/tyxml-lwd/Makefile Normal file
View File

@ -0,0 +1,2 @@
all:
dune build @all

7
lib/tyxml-lwd/dune Normal file
View File

@ -0,0 +1,7 @@
(library
(name tyxml_lwd)
(wrapped false)
(public_name tyxml-lwd)
(modes byte)
(preprocess (pps js_of_ocaml-ppx))
(libraries tyxml.functor js_of_ocaml lwd))

31
lib/tyxml-lwd/lwdom.ml Normal file
View File

@ -0,0 +1,31 @@
module Xml = Tyxml_lwd.Xml
module Svg = Svg_f.Make(Tyxml_lwd.Xml)
module Html = Html_f.Make(Tyxml_lwd.Xml)(Svg)
type 'a t = 'a Xml.Elt.t
type 'a attr = 'a Xml.Attr.t
let elt x = Lwd.pure (Lwd_seq.element x)
let attr x : _ Xml.Attr.t = Lwd.pure (Some x)
let lwd_attr x : _ Xml.Attr.t = Lwd.map (fun x -> Some x) x
let dom_nodes x =
let rec fold x acc = match Lwd_seq.view x with
| Lwd_seq.Empty -> acc
| Lwd_seq.Element x -> x :: acc
| Lwd_seq.Concat (l, r) -> fold l (fold r acc)
in
fold x []
let children = function
| [] -> Xml.Child.nil ()
| [x] -> x
| [x; y] -> Lwd.map2 Lwd_seq.concat x y
| xs -> Lwd_utils.reduce Lwd_seq.lwd_monoid xs
let children_array = function
| [||] -> Xml.Child.nil ()
| [|x|] -> x
| [|x; y|] -> Lwd.map2 Lwd_seq.concat x y
| xs ->
Lwd_seq.bind (Lwd_seq.lift (Lwd.pure (Lwd_seq.of_array xs))) (fun x -> x)

32
lib/tyxml-lwd/lwdom.mli Normal file
View File

@ -0,0 +1,32 @@
open Js_of_ocaml
open Tyxml_lwd
module Xml = Xml
module Svg : Svg_sigs.Make(Xml).T
module Html : Html_sigs.Make(Xml)(Svg).T
(** FIXME
- Explain that in this DOM binding, element is a monoid.
- Explain how to manage roots, connect to Browser document *)
type 'a t = 'a Xml.Elt.t
type 'a attr = 'a Xml.Attr.t
val elt : 'a -> 'a t
(** Create an element from a value *)
val children : 'a t list -> 'a t
(** Flatten a list of elements *)
val children_array : 'a t array -> 'a t
(** Flatten an array of elements *)
val attr : 'a -> 'a attr
(** Make a constant attribute *)
val lwd_attr : 'a Lwd.t -> 'a attr
(** Make a reactive attribute *)
(** FIXME: Expose higher-level interface, especially for managing roots and
connecting to the document *)
val dom_nodes : 'a Html.data Lwd_seq.t -> Dom.node Js.t list

264
lib/tyxml-lwd/tyxml_lwd.ml Normal file
View File

@ -0,0 +1,264 @@
open Js_of_ocaml
let js_string_of_float f = (Js.number_of_float f)##toString
let js_string_of_int i = (Js.number_of_float (float_of_int i))##toString
module Elt = struct
type 'a t = 'a Lwd_seq.t Lwd.t
type 'a child = 'a t
let inject x = x
end
module Child = struct
type 'a t = 'a Elt.t
let return x = Lwd.pure (Lwd_seq.element x)
type 'a list = 'a t
let nil = let nil = Lwd.pure Lwd_seq.empty in fun () -> nil
let singleton x = x
let append l1 l2 = Lwd.map2 Lwd_seq.concat l1 l2
let cons x xs = append (singleton x) xs
end
module Attr = struct
type 'a t = 'a option Lwd.t
type (-'a,'b) ft = 'a -> 'b
let return x = Lwd.return (Some x)
let fmap f x = Lwd.map (function None -> None | Some x -> Some (f x)) x
end
module Xml
: Xml_sigs.T
with module Elt = Elt
and module Child = Child
and module Attr = Attr
and type data = Dom.node Js.t
and type event_handler = (Dom_html.event Js.t -> bool) Attr.t
and type mouse_event_handler = (Dom_html.mouseEvent Js.t -> bool) Attr.t
and type keyboard_event_handler = (Dom_html.keyboardEvent Js.t -> bool) Attr.t
and type touch_event_handler = (Dom_html.touchEvent Js.t -> bool) Attr.t
= struct
module Elt = Elt
module Attr = Attr
type 'a attr = 'a Attr.t
module Child = Child
type uri = string
let uri_of_string s = s
let string_of_uri s = s
type aname = string
type event_handler = (Dom_html.event Js.t -> bool) attr
type mouse_event_handler = (Dom_html.mouseEvent Js.t -> bool) attr
type keyboard_event_handler = (Dom_html.keyboardEvent Js.t -> bool) attr
type touch_event_handler = (Dom_html.touchEvent Js.t -> bool) attr
type 'a attrib_k =
| Event : (Dom_html.event Js.t -> bool) attrib_k
| Event_mouse : (Dom_html.mouseEvent Js.t -> bool) attrib_k
| Event_keyboard : (Dom_html.keyboardEvent Js.t -> bool) attrib_k
| Event_touch : (Dom_html.touchEvent Js.t -> bool) attrib_k
| Attr_float : float attrib_k
| Attr_int : int attrib_k
| Attr_string : string attrib_k
| Attr_space_sep : string list attrib_k
| Attr_comma_sep : string list attrib_k
| Attr_uri : string attrib_k
| Attr_uris : string list attrib_k
type 'a attrib_v = {name: string; kind : 'a attrib_k; value: 'a attr}
type attrib = Attrib : 'a attrib_v -> attrib [@@ocaml.unboxed]
let attrib kind name value = Attrib {name; kind; value}
let float_attrib n v = attrib Attr_float n v
let int_attrib n v = attrib Attr_int n v
let string_attrib n v = attrib Attr_string n v
let space_sep_attrib n v = attrib Attr_space_sep n v
let comma_sep_attrib n v = attrib Attr_comma_sep n v
let event_handler_attrib n v = attrib Event n v
let mouse_event_handler_attrib n v = attrib Event_mouse n v
let keyboard_event_handler_attrib n v = attrib Event_keyboard n v
let touch_event_handler_attrib n v = attrib Event_touch n v
let uri_attrib n v = attrib Attr_uri n v
let uris_attrib n v = attrib Attr_uris n v
let attach
(type a) (node: #Dom.element Js.t) (k: a attrib_v) (v : a option) : unit =
let name_js = Js.string k.name in
match v with
| None -> begin match k.kind with
| Event | Event_mouse | Event_keyboard | Event_touch ->
Js.Unsafe.set node name_js Js.null
| Attr_float | Attr_int | Attr_string | Attr_space_sep
| Attr_comma_sep | Attr_uri | Attr_uris ->
Js.Unsafe.delete node name_js
end
| Some v -> begin match k.kind with
| Event -> Js.Unsafe.set node name_js (fun ev -> Js.bool (v ev))
| Event_mouse -> Js.Unsafe.set node name_js (fun ev -> Js.bool (v ev))
| Event_keyboard -> Js.Unsafe.set node name_js (fun ev -> Js.bool (v ev))
| Event_touch -> Js.Unsafe.set node name_js (fun ev -> Js.bool (v ev))
| Attr_float -> Js.Unsafe.set node name_js (Js.float v)
| Attr_int -> Js.Unsafe.set node name_js v
| Attr_string -> Js.Unsafe.set node name_js (Js.string v)
| Attr_space_sep -> Js.Unsafe.set node name_js (Js.string (String.concat " " v))
| Attr_comma_sep -> Js.Unsafe.set node name_js (Js.string (String.concat "," v))
| Attr_uri -> Js.Unsafe.set node name_js (Js.string v)
| Attr_uris -> Js.Unsafe.set node name_js (Js.string (String.concat " " v))
end
(** Element *)
type data = Dom.node Js.t
type elt = data Elt.t
type children = data Child.list
type ename = string
let as_node (x : #Dom.node Js.t) = (x :> Dom.node Js.t)
let pure_node x = Child.return (as_node x)
let empty () = pure_node Dom_html.document##createDocumentFragment
let comment c = pure_node (Dom_html.document##createComment (Js.string c))
let string_monoid =
let cat a b = match a, b with "", x | x, "" -> x | a, b -> a ^ b in
("", cat)
let pcdata input =
let node =
Lwd_seq.element (Dom_html.document##createTextNode (Js.string ""))
in
let text = Lwd_seq.fold_monoid (fun x -> x) string_monoid input in
Lwd.map (fun text ->
begin match Lwd_seq.view node with
| Lwd_seq.Element elt -> elt##.data := Js.string text;
| _ -> assert false
end;
(node : Dom.text Js.t Lwd_seq.t :> data Lwd_seq.t)
) text
let encodedpcdata = pcdata
let entity =
let string_fold s ~pos ~init ~f =
let r = ref init in
for i = pos to String.length s - 1 do
let c = s.[i] in
r := f !r c
done;
!r
in
let invalid_entity e = failwith (Printf.sprintf "Invalid entity %S" e) in
let int_of_char = function
| '0' .. '9' as x -> Some (Char.code x - Char.code '0')
| 'a' .. 'f' as x -> Some (Char.code x - Char.code 'a' + 10)
| 'A' .. 'F' as x -> Some (Char.code x - Char.code 'A' + 10)
| _ -> None
in
let parse_int ~pos ~base e =
string_fold e ~pos ~init:0 ~f:(fun acc x ->
match int_of_char x with
| Some d when d < base -> (acc * base) + d
| Some _ | None -> invalid_entity e)
in
let is_alpha_num = function
| '0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' -> true
| _ -> false
in
fun e ->
let len = String.length e in
let str =
if len >= 1 && Char.equal e.[0] '#'
then
let i =
if len >= 2 && (Char.equal e.[1] 'x' || Char.equal e.[1] 'X')
then parse_int ~pos:2 ~base:16 e
else parse_int ~pos:1 ~base:10 e
in
Js.string_constr##fromCharCode i
else if string_fold e ~pos:0 ~init:true ~f:(fun acc x ->
(* This is not quite right according to
https://www.xml.com/axml/target.html#NT-Name.
but it seems to cover all html5 entities
https://dev.w3.org/html5/html-author/charref *)
acc && is_alpha_num x)
then
match e with
| "quot" -> Js.string "\""
| "amp" -> Js.string "&"
| "apos" -> Js.string "'"
| "lt" -> Js.string "<"
| "gt" -> Js.string ">"
| "" -> invalid_entity e
| _ -> Dom_html.decode_html_entities (Js.string ("&" ^ e ^ ";"))
else invalid_entity e
in
pure_node (Dom_html.document##createTextNode str)
let attach_attribs node l =
Lwd_utils.pack ((), fun () () -> ())
(List.map (fun (Attrib a) -> Lwd.map (attach node a) a.value) l)
let leaf ?(a = []) name : elt =
let e = Dom_html.document##createElement (Js.string name) in
let e' = Lwd_seq.element (e : Dom_html.element Js.t :> data) in
Lwd.map' (attach_attribs e a) (fun () -> e')
type child_tree =
| Leaf of data
| Inner of { mutable bound: data Js.opt;
left: child_tree; right: child_tree; }
let child_node node = Leaf node
let child_join left right = Inner { bound = Js.null; left; right }
let update_children (self : data) (children : children) : unit Lwd.t =
let reducer =
ref (Lwd_seq.Reducer.make ~map:child_node ~reduce:child_join)
in
Lwd.map' children @@ fun children ->
let dropped, reducer' =
Lwd_seq.Reducer.update_and_get_dropped !reducer children in
let remove_child child () = match child with
| Leaf node -> ignore (self##removeChild node)
| Inner _ -> ()
in
Lwd_seq.Reducer.fold_dropped `Map remove_child dropped ();
begin match Lwd_seq.Reducer.reduce reducer' with
| None -> ()
| Some tree ->
let rec update acc = function
| Leaf x ->
ignore (self##insertBefore x acc);
Js.some x
| Inner t ->
if Js.Opt.test t.bound then t.bound else (
let acc = update acc t.right in
let acc = update acc t.left in
t.bound <- acc;
acc
)
in
ignore (update Js.null tree)
end
let node ?(a = []) name children : elt =
let e = Dom_html.document##createElement (Js.string name) in
let e' = Lwd_seq.element e in
Lwd.map2'
(update_children (e :> data) children)
(attach_attribs e a)
(fun () () -> (e' :> data Lwd_seq.t))
let cdata s = pure_node (Dom_html.document##createTextNode (Js.string s))
let cdata_script s = cdata s
let cdata_style s = cdata s
end

25
tyxml-lwd.opam Normal file
View File

@ -0,0 +1,25 @@
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "Hello"
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" "lwd" "tyxml" "js_of_ocaml"]
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"