Compare commits
14 Commits
master
...
pre-releas
Author | SHA1 | Date |
---|---|---|
Frédéric Bour | fa091a3d1f | |
Frédéric Bour | 7b03af8a2d | |
Frédéric Bour | a9095faa6f | |
Frédéric Bour | 1067a65207 | |
Frédéric Bour | addb56401d | |
Frédéric Bour | da494a2613 | |
Frédéric Bour | ebd0d5c446 | |
Drup | 58fd8c6b85 | |
Frédéric Bour | bfc481aa54 | |
Frédéric Bour | a995047176 | |
Frédéric Bour | b4447f82f3 | |
Frédéric Bour | fe42d56bf5 | |
Frédéric Bour | 9eb18e2207 | |
Frédéric Bour | 07823fed56 |
6
Makefile
6
Makefile
|
@ -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
|
||||
|
||||
|
|
20
README.md
20
README.md
|
@ -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:
|
||||
|
|
|
@ -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")
|
||||
|
|
|
@ -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 =
|
||||
|
|
|
@ -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 =
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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} *)
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 *)
|
||||
|
|
|
@ -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 []
|
||||
|
|
|
@ -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] *)
|
||||
|
|
|
@ -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.
|
||||
*)
|
||||
|
|
|
@ -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 *)
|
||||
|
|
|
@ -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 =
|
||||
|
|
|
@ -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
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -0,0 +1,2 @@
|
|||
all:
|
||||
dune build @all
|
|
@ -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))
|
|
@ -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)
|
|
@ -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
|
|
@ -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
|
|
@ -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"
|
Loading…
Reference in New Issue