Compare commits

...

22 Commits

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

+ 9
- 0
Makefile View File

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

TESTS=minimal misc reranger stress

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

run-minimal:
dune exec examples/minimal.bc

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

run-pretty:
dune exec examples/pretty.bc

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

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



+ 12
- 0
dune-project View File

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

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

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

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


+ 6
- 0
examples/dune View File

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

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


+ 14
- 6
examples/minimal.ml View File

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

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

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



+ 76
- 0
examples/pretty.ml View File

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

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

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


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

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

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

let doc = Lwd_table.make ()

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

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

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

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

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

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

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

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

let dummy = Pure (Any.any ())

let operator desc =


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

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

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

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


+ 85
- 12
lib/lwd/lwd_seq.ml View File

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

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

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

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



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

@@ -36,6 +36,14 @@ val element : 'a -> 'a seq
*)
val concat : 'a seq -> 'a seq -> 'a seq

val monoid : 'a t Lwd_utils.monoid
val lwd_monoid : 'a t Lwd.t Lwd_utils.monoid

val of_list : 'a list -> 'a seq
val of_array : 'a array -> 'a seq
val to_list : 'a seq -> 'a list
val to_array : 'a seq -> 'a array

(* Look at the contents of a sequence *)

type ('a, 'b) view =


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

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

let pure_pack (zero, plus) items =
let map_reduce inj (zero, plus) items =
let rec cons_monoid c xs v =
match xs with
| (c', v') :: xs when c = c' ->
cons_monoid (c + 1) xs (plus v' v)
| xs -> (c, v) :: xs
in
match List.fold_left (cons_monoid 0) [] items with
let cons_monoid xs v = cons_monoid 0 xs (inj v) in
match List.fold_left cons_monoid [] items with
| [] -> zero
| (_,x) :: xs ->
List.fold_left (fun acc (_, v) -> plus v acc) x xs

let pure_pack 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' ->


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

@@ -5,6 +5,8 @@ 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

val map_reduce : ('a -> 'b) -> 'b monoid -> 'a list -> 'b

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

val map_l : ('a -> 'b Lwd.t) -> 'a list -> 'b list Lwd.t


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

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

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

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

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

(* A type of integers with infinity. *)

type requirement =
int (* with infinity *)

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

let infinity : requirement =
max_int

(* Addition of integers with infinity. *)

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

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

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

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

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

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

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

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

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

type ui = Nottui.ui

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

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

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

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

(* The type of documents. *)

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

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

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

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

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

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

(* Document constructors. *)

let empty = Blank 0

let ui ui = Ui ui

let hardline = Hardline

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

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

let internal_break i =
if_flat (blank i) hardline

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

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

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

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

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

open Nottui

(* Some intermediate UI *)

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

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

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

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

(* Flat renderer *)

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

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

(* Nonflat renderer.

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

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

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

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

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

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

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

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

(* The engine's entry point. *)

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

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

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

(* The type of documents *)
type t

(* The empty document *)
val empty : t

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

(* Forced line break *)
val hardline : t

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

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

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

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

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

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

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

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

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

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

let scroll_step = 1

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

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

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

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

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

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

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


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

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


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

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

val bottom_left : t
val bottom_right : t

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

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

let pp_direction ppf dir =
let text = match dir with
| `Negative -> "`Negative"
@@ -134,6 +128,35 @@ struct
end
type gravity = Gravity.t

module Interval : sig
type t = private int
val make : int -> int -> t
val shift : t -> int -> t
val fst : t -> int
val snd : t -> int
(*val size : t -> int*)
val zero : t
end = struct
type t = int

let half = Sys.word_size lsr 1
let mask = (1 lsl half) - 1

let make x y =
let size = y - x in
(*assert (size >= 0);*)
(x lsl half) lor (size land mask)

let shift t d =
t + d lsl half

let fst t = t asr half
let size t = t land mask
let snd t = fst t + size t

let zero = 0
end

module Ui =
struct
type may_handle = [ `Unhandled | `Handled ]
@@ -165,42 +188,41 @@ struct
let pp_layout_spec ppf { w; h; sw; sh } =
Format.fprintf ppf "{ w = %d; h = %d; sw = %d; sh = %d }" w h sw sh

type 'a desc =
| Atom of image
| Size_sensor of 'a * (int -> int -> unit)
| Resize of 'a * Gravity.t2 * A.t
| Mouse_handler of 'a * mouse_handler
| Focus_area of 'a * (key -> may_handle)
| Scroll_area of 'a * int * int
| Event_filter of 'a * ([`Key of key | `Mouse of mouse] -> may_handle)
| Overlay of 'a overlay
| X of 'a * 'a
| Y of 'a * 'a
| Z of 'a * 'a

and 'a overlay = {
o_n : 'a;
o_h : mouse_handler;
o_x : int;
o_y : int;
o_z : int;
o_origin : Gravity.t;
o_direction : Gravity.t;
}
type flags = int
let flags_none = 0
let flag_transient_sensor = 1
let flag_permanent_sensor = 2

type size_sensor = w:int -> h:int -> unit
type frame_sensor = x:int -> y:int -> w:int -> h:int -> unit -> unit

type t = {
w : int; sw : int;
h : int; sh : int;
desc : t desc;
mutable desc : desc;
focus : Focus.status;
mutable flags : flags;
mutable sensor_cache : (int * int * int * int) option;
mutable cache : cache;
}
and cache = {
vx1 : int; vy1 : int;
vx2 : int; vy2 : int;
vx : Interval.t; vy : Interval.t;
image : image;
overlays: t overlay list;
}
and desc =
| Atom of image
| Size_sensor of t * size_sensor
| Transient_sensor of t * frame_sensor
| Permanent_sensor of t * frame_sensor
| Resize of t * Gravity.t2 * A.t
| Mouse_handler of t * mouse_handler
| Focus_area of t * (key -> may_handle)
| Scroll_area of t * int * int
| Event_filter of t * ([`Key of key | `Mouse of mouse] -> may_handle)
| X of t * t
| Y of t * t
| Z of t * t


let layout_spec t : layout_spec =
{ w = t.w; h = t.h; sw = t.sw; sh = t.sh }
@@ -210,18 +232,19 @@ struct
let layout_stretch_height t = t.sh

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

let empty : t =
{ w = 0; sw = 0; h = 0; sh = 0;
focus = Focus.empty; desc = Atom I.empty; cache }
{ w = 0; sw = 0; h = 0; sh = 0; flags = flags_none;
focus = Focus.empty; desc = Atom I.empty;
sensor_cache = None; cache }

let atom img : t =
{ w = I.width img; sw = 0;
h = I.height img; sh = 0;
focus = Focus.empty;
desc = Atom img; cache }
focus = Focus.empty; flags = flags_none;
desc = Atom img;
sensor_cache = None; cache; }

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

@@ -241,6 +264,14 @@ struct
let size_sensor handler t : t =
{ t with desc = Size_sensor (t, handler) }

let transient_sensor frame_sensor t =
{ t with desc = Transient_sensor (t, frame_sensor);
flags = t.flags lor flag_transient_sensor }

let permanent_sensor frame_sensor t =
{ t with desc = Permanent_sensor (t, frame_sensor);
flags = t.flags lor flag_permanent_sensor }

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

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

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

let event_filter ?focus f t : t =
let focus = match focus with
| None -> t.focus
@@ -275,19 +293,25 @@ struct
let join_x a b = {
w = (a.w + b.w); sw = (a.sw + b.sw);
h = (maxi a.h b.h); sh = (maxi a.sh b.sh);
focus = Focus.merge a.focus b.focus; desc = X (a, b); cache
flags = a.flags lor b.flags;
focus = Focus.merge a.focus b.focus; desc = X (a, b);
sensor_cache = None; cache
}

let join_y a b = {
w = (maxi a.w b.w); sw = (maxi a.sw b.sw);
h = (a.h + b.h); sh = (a.sh + b.sh);
focus = Focus.merge a.focus b.focus; desc = Y (a, b); cache;
flags = a.flags lor b.flags;
focus = Focus.merge a.focus b.focus; desc = Y (a, b);
sensor_cache = None; cache;
}

let join_z a b = {
w = (maxi a.w b.w); sw = (maxi a.sw b.sw);
h = (maxi a.h b.h); sh = (maxi a.sh b.sh);
focus = Focus.merge a.focus b.focus; desc = Z (a, b); cache;
flags = a.flags lor b.flags;
focus = Focus.merge a.focus b.focus; desc = Z (a, b);
sensor_cache = None; cache;
}

let pack_x = (empty, join_x)
@@ -309,6 +333,10 @@ struct
| Atom _ -> Format.fprintf ppf "Atom _"
| Size_sensor (desc, _) ->
Format.fprintf ppf "Size_sensor (@[%a,@ _@])" pp desc
| Transient_sensor (desc, _) ->
Format.fprintf ppf "Transient_sensor (@[%a,@ _@])" pp desc
| Permanent_sensor (desc, _) ->
Format.fprintf ppf "Permanent_sensor (@[%a,@ _@])" pp desc
| Resize (desc, gravity, _bg) ->
Format.fprintf ppf "Resize (@[%a,@ %a,@ %a@])" pp desc
Gravity.pp (Gravity.p1 gravity)
@@ -321,22 +349,16 @@ struct
Format.fprintf ppf "Scroll_area (@[%a,@ _@])" pp n
| Event_filter (n, _) ->
Format.fprintf ppf "Event_filter (@[%a,@ _@])" pp n
| Overlay o -> Format.fprintf ppf "Overlay (@[%a,@ _@])" pp_overlay o
| X (a, b) -> Format.fprintf ppf "X (@[%a,@ %a@])" pp a pp b
| Y (a, b) -> Format.fprintf ppf "Y (@[%a,@ %a@])" pp a pp b
| Z (a, b) -> Format.fprintf ppf "Z (@[%a,@ %a@])" pp a pp b

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

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

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

let update_focus ui =
match ui.focus with
| Focus.Empty | Focus.Handle _ -> ()
| Focus.Conflict i -> solve_focus ui i

let update t size ui =
t.size <- size;
t.view <- ui;
update_focus ui

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

let split ~a ~sa ~b ~sb total =
let stretch = sa + sb in
let flex = total - a - b in
@@ -410,12 +419,72 @@ struct
| `Neutral -> (flex / 2, fixed)
| `Positive -> (flex, fixed)

let has_transient_sensor flags = flags land flag_transient_sensor <> 0
let has_permanent_sensor flags = flags land flag_permanent_sensor <> 0

let rec update_sensors ox oy sw sh ui =
if has_transient_sensor ui.flags || (
has_permanent_sensor ui.flags &&
match ui.sensor_cache with
| None -> false
| Some (ox', oy', sw', sh') ->
ox = ox' && oy = oy' && sw = sw' && sh = sh'
)
then (
ui.flags <- ui.flags land lnot flag_transient_sensor;
if has_permanent_sensor ui.flags then
ui.sensor_cache <- Some (ox, oy, sw, sh);
match ui.desc with
| Atom _ -> ()
| Size_sensor (t, _) | Mouse_handler (t, _)
| Focus_area (t, _) | Event_filter (t, _) ->
update_sensors ox oy sw sh t
| Transient_sensor (t, sensor) ->
ui.desc <- t.desc;
let sensor = sensor ~x:ox ~y:oy ~w:sw ~h:sh in
update_sensors ox oy sw sh t;
sensor ()
| Permanent_sensor (t, sensor) ->
let sensor = sensor ~x:ox ~y:oy ~w:sw ~h:sh in
update_sensors ox oy sw sh t;
sensor ()
| Resize (t, g, _) ->
let open Gravity in
let dx, rw = pack ~fixed:t.w ~stretch:t.sw sw (h (p1 g)) (h (p2 g)) in
let dy, rh = pack ~fixed:t.h ~stretch:t.sh sh (v (p1 g)) (v (p2 g)) in
update_sensors (ox + dx) (oy + dy) rw rh t
| Scroll_area (t, sx, sy) ->
update_sensors (ox - sx) (oy - sy) sw sh t
| X (a, b) ->
let aw, bw = split ~a:a.w ~sa:a.sw ~b:b.w ~sb:b.sw sw in
update_sensors ox oy aw sh a;
update_sensors (ox + aw) oy bw sh b
| Y (a, b) ->
let ah, bh = split ~a:a.h ~sa:a.sh ~b:b.h ~sb:b.sh sh in
update_sensors ox oy sw ah a;
update_sensors ox (oy + ah) sw bh b
| Z (a, b) ->
update_sensors ox oy sw sh a;
update_sensors ox oy sw sh b
)

let update_focus ui =
match ui.focus with
| Focus.Empty | Focus.Handle _ -> ()
| Focus.Conflict i -> solve_focus ui i

let update t size ui =
t.size <- size;
t.view <- ui;
update_sensors 0 0 (fst size) (snd size) ui;
update_focus ui

let dispatch_mouse st x y btn w h t =
let handle ox oy f =
match f ~x:(x - ox) ~y:(y - oy) btn with
| `Unhandled -> false
| `Handled -> true
| `Grab f -> st.mouse_grab <- Some (ox, oy, f); true
| `Grab f -> st.mouse_grab <- Some f; true
in
let rec aux ox oy sw sh t =
match t.desc with
@@ -439,8 +508,8 @@ struct
assert (_offsetx = 0 && _offsety = 0);
(x - ox >= 0 && x - ox <= rw && y - oy >= 0 && y - oy <= rh) &&
(aux ox oy sw sh t || handle ox oy f)
| Size_sensor (desc, _) ->
aux ox oy sw sh desc
| Size_sensor (desc, _)
| Transient_sensor (desc, _) | Permanent_sensor (desc, _)
| Focus_area (desc, _) ->
aux ox oy sw sh desc
| Scroll_area (desc, sx, sy) ->
@@ -450,32 +519,20 @@ struct
let dx, rw = pack ~fixed:t.w ~stretch:t.sw sw (h (p1 g)) (h (p2 g)) in
let dy, rh = pack ~fixed:t.h ~stretch:t.sh sh (v (p1 g)) (v (p2 g)) in
aux (ox + dx) (oy + dy) rw rh t
| Overlay _ ->
false
| Event_filter (n, f) ->
begin match f (`Mouse (`Press btn, (x, y), [])) with
| `Handled -> true
| `Unhandled -> aux ox oy sw sh n
end
in
let rec overlays ox oy ovs =
List.exists (fun o ->
let ox = ox + o.o_x and oy = oy + o.o_y in
let ow = I.width o.o_n.cache.image in
let oh = I.height o.o_n.cache.image in
overlays ox oy o.o_n.cache.overlays
|| aux ox oy (ox + ow) (oy + oh) o.o_n
|| handle ox oy o.o_h
) (sort_overlays ovs)
in
overlays 0 0 t.cache.overlays || aux 0 0 w h t
aux 0 0 w h t

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

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

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

let resize_canvas rw rh image =
let w = I.width image in
let h = I.height image in
@@ -515,20 +570,23 @@ struct
let rec render_node vx1 vy1 vx2 vy2 sw sh t : cache =
if
let cache = t.cache in
vx1 >= cache.vx1 && vy1 >= cache.vy1 &&
vx2 <= cache.vx2 && vy2 <= cache.vy2 &&
vx1 >= Interval.fst cache.vx && vy1 >= Interval.fst cache.vy &&
vx2 <= Interval.snd cache.vx && vy2 <= Interval.snd cache.vy &&
same_size sw sh cache.image
then t.cache
else if vx2 < 0 || vy2 < 0 || sw < vx1 || sh < vy1 then
{ vx1; vy1; vx2; vy2; image = I.void sw sh; overlays = [] }
let vx = Interval.make vx1 vx2 and vy = Interval.make vy1 vy2 in
{ vx; vy; image = I.void sw sh }
else
let cache = match t.desc with
| Atom image ->
{ vx1 = 0; vy1 = 0; vx2 = sw; vy2 = sh;
overlays = [];
{ vx = Interval.make 0 sw;
vy = Interval.make 0 sh;
image = resize_canvas sw sh image }
| Size_sensor (desc, handler) ->
handler sw sh;
handler ~w:sw ~h:sh;
render_node vx1 vy1 vx2 vy2 sw sh desc
| Transient_sensor (desc, _) | Permanent_sensor (desc, _) ->
render_node vx1 vy1 vx2 vy2 sw sh desc
| Focus_area (desc, _) | Mouse_handler (desc, _) ->
render_node vx1 vy1 vx2 vy2 sw sh desc
@@ -536,45 +594,44 @@ struct
let cache = render_node
(vx1 + sx) (vy1 + sy) (vx2 + sx) (vy2 + sy) (sx + sw) (sy + sh) t'
in
{ vx1; vx2; vy1; vy2;
overlays = (List.map (shift_o (-sx) (-sy)) cache.overlays);
image = resize_canvas sw sh (I.crop ~l:sx ~t:sy cache.image) }
let vx = Interval.make vx1 vx2 and vy = Interval.make vy1 vy2 in
let image = resize_canvas sw sh (I.crop ~l:sx ~t:sy cache.image) in
{ vx; vy; image }
| X (a, b) ->
let aw, bw = split ~a:a.w ~sa:a.sw ~b:b.w ~sb:b.sw sw in
let ca = render_node vx1 vy1 vx2 vy2 aw sh a in
let cb = render_node (vx1 - aw) vy1 (vx2 - aw) vy2 bw sh b in
{ vx1 = maxi ca.vx1 (cb.vx1 + aw);
vx2 = mini ca.vx2 (cb.vx2 + aw);
vy1 = maxi ca.vy1 cb.vy1;
vy2 = mini ca.vy2 cb.vy2;
overlays = List.map (shift_o aw 0) cb.overlays @ ca.overlays;
image = resize_canvas sw sh (I.(<|>) ca.image cb.image) }
let vx = Interval.make
(maxi (Interval.fst ca.vx) (Interval.fst cb.vx + aw))
(mini (Interval.snd ca.vx) (Interval.snd cb.vx + aw))
and vy = Interval.make
(maxi (Interval.fst ca.vy) (Interval.fst cb.vy))
(mini (Interval.snd ca.vy) (Interval.snd cb.vy))
and image = resize_canvas sw sh (I.(<|>) ca.image cb.image) in
{ vx; vy; image }
| Y (a, b) ->
let ah, bh = split ~a:a.h ~sa:a.sh ~b:b.h ~sb:b.sh sh in
let ca = render_node vx1 vy1 vx2 vy2 sw ah a in
let cb = render_node vx1 (vy1 - ah) vx2 (vy2 - ah) sw bh b in
{ vx1 = maxi ca.vx1 cb.vx1;
vx2 = mini ca.vx2 cb.vx2;
vy1 = maxi ca.vy1 (cb.vy1 + ah);
vy2 = mini ca.vy2 (cb.vy2 + ah);
overlays = List.map (shift_o 0 ah) cb.overlays @ ca.overlays;
image = resize_canvas sw sh (I.(<->) ca.image cb.image) }
let vx = Interval.make
(maxi (Interval.fst ca.vx) (Interval.fst cb.vx))
(mini (Interval.snd ca.vx) (Interval.snd cb.vx))
and vy = Interval.make
(maxi (Interval.fst ca.vy) (Interval.fst cb.vy + ah))
(mini (Interval.snd ca.vy) (Interval.snd cb.vy + ah))
and image = resize_canvas sw sh (I.(<->) ca.image cb.image) in
{ vx; vy; image }
| Z (a, b) ->
let ca = render_node vx1 vy1 vx2 vy2 sw sh a in
let cb = render_node vx1 vy1 vx2 vy2 sw sh b in
{ vx1 = maxi ca.vx1 cb.vx1;
vx2 = mini ca.vx2 cb.vx2;
vy1 = maxi ca.vy1 cb.vy1;
vy2 = mini ca.vy2 cb.vy2;
overlays = cb.overlays @ ca.overlays;
image = resize_canvas sw sh (I.(</>) cb.image ca.image) }
| Overlay overlay ->
let ow = overlay.o_n.w and oh = overlay.o_n.h in
let c = render_node 0 0 ow oh ow oh overlay.o_n in
{ vx1; vx2; vy1; vy2;
overlays = overlay ::
List.map (shift_o overlay.o_x overlay.o_y) c.overlays;
image = resize_canvas sw sh I.empty }
let vx = Interval.make
(maxi (Interval.fst ca.vx) (Interval.fst cb.vx))
(mini (Interval.snd ca.vx) (Interval.snd cb.vx))
and vy = Interval.make
(maxi (Interval.fst ca.vy) (Interval.fst cb.vy))
(mini (Interval.snd ca.vy) (Interval.snd cb.vy))
and image = resize_canvas sw sh (I.(</>) cb.image ca.image) in
{ vx; vy; image }
| Resize (t, g, bg) ->
let open Gravity in
let dx, rw = pack ~fixed:t.w ~stretch:t.sw sw (h (p1 g)) (h (p2 g)) in
@@ -589,30 +646,17 @@ struct
else
image
in
{ vx1 = c.vx1 + dx; vx2 = c.vx2 + dx;
vy1 = c.vy1 + dy; vy2 = c.vy2 + dy;
overlays = List.map (shift_o dx dy) c.overlays;
image
}
let vx = Interval.shift c.vx dx in
let vy = Interval.shift c.vy dy in
{ vx; vy; image }
| Event_filter (t, _f) ->
render_node vx1 vy1 vx2 vy2 sw sh t
in
t.cache <- cache;
cache

let image st =
let flatten (im,todo) o =
let todo = List.map (shift_o o.o_x o.o_y) o.o_n.cache.overlays @ todo in
let ovi = I.pad ~l:o.o_x ~t:o.o_y o.o_n.cache.image in
(I.(</>) ovi im, todo)
in
let rec process = function
| (im, []) -> im
| (im, ovs) -> process (List.fold_left flatten (im, []) ovs)
in
let (w, h) = st.size in
let cache = render_node 0 0 w h w h st.view in
process (cache.image, cache.overlays)
let image {size = (w, h); view; _} =
(render_node 0 0 w h w h view).image

let dispatch_raw_key st key =
let rec iter (st: ui list) : [> `Unhandled] =
@@ -620,7 +664,7 @@ struct
| [] -> `Unhandled
| ui :: tl ->
begin match ui.desc with
| Atom _ | Overlay _ -> iter tl
| Atom _ -> iter tl
| X (a, b) | Y (a, b) | Z (a, b) ->
(* Try left/top most branch first *)
let st' =
@@ -638,6 +682,7 @@ struct
| `Unhandled -> iter tl
end
| Mouse_handler (t, _) | Size_sensor (t, _)
| Transient_sensor (t, _) | Permanent_sensor (t, _)
| Scroll_area (t, _, _) | Resize (t, _, _) ->
iter (t :: tl)
| Event_filter (t, f) ->
@@ -662,8 +707,9 @@ struct

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


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

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

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

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

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


+ 2
- 0
lib/tyxml-lwd/Makefile View File

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

+ 6
- 0
lib/tyxml-lwd/dune View File

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

+ 264
- 0
lib/tyxml-lwd/tyxml_lwd.ml 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
- 0
nottui-pretty.opam View File

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

+ 25
- 0
tyxml-lwd.opam 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"