console/boot
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re-arranged

Browse Source
This commit is contained in:
cqc
2022-11-22 23:38:53 -06:00
parent 60c83c608a
commit b5d846b35d
1 changed files with 502 additions and 614 deletions
Download Patch File Download Diff File Expand all files Collapse all files

686
human.ml
View File

@ -976,24 +976,31 @@ module Panel = struct
end
module Ui = struct
(* Tree-like structure of Ui elements, from the entire display down to individual glyphs. *)
(* i think this is gonna end up being a binary tree?? *)
(* Tree-like document structure of Ui elements, from the top level window down
to individual glyphs, and built with Lwd.
(* TODO make sure this is LCRS: https://en.wikipedia.org/wiki/Left-child_right-sibling_binary_tree *)
Probably an LCRS binary tree.
*)
open Gg
type t =
[ `Atom of atom
| `Attr of attr * node
| `Join of dir * node * node ]
type draw_context = { vg : NVG.t; style : Style.t }
and draw = draw_context -> Gg.p2 -> Gg.p2
and node = { mutable parent : parent; mutable t : t; n : int }
and parent = [ `Left of node | `Right of node | `None ]
and cursor = { root : node; mutable sel : node }
module Page = struct
type t =
(* TODO figure out how to allow extending `node` with custom document tree combinators *)
[ `Atom of atom | `Attr of attr * t | `Join of dir * t * t ]
and step = [ `Next | `Left | `Right ]
and path = step list
and cursor = { path : path; root : t }
and atom =
[ `Image of image
[ (*`Lwd of t
| *)
`Image of
image
| `Uchar of Uchar.t
| `Boundary of boundary
| `Hint of [ `Line | `Other ]
@ -1005,341 +1012,94 @@ module Panel = struct
| `Handler of handler
| `Draw of draw ]
and p = P2.t
and dir = [ `X | `Y | `Z ]
and image = NVG.Image.image
and boundary = [ `Char | `Word | `Phrase | `Line | `Page | `Text ]
and boundary =
[ `Char | `Word | `Phrase | `Line | `Page | `Text ]
and style = Style.t
and handler = node -> Event.t -> Event.t option
and draw_context = { vg : NVG.t; style : Style.t }
and draw = draw_context -> p -> p
and handler = t -> Event.t -> Event.t option
let node_count = ref 0
let node_n () =
node_count := !node_count + 1;
!node_count - 1
let set_parent_on_children n : node =
(match n.t with
| `Atom _ -> ()
| `Attr (_, a) -> a.parent <- `Left n
| `Join (_, a, b) ->
a.parent <- `Left n;
b.parent <- `Right n);
n
let sub (n : node) : node =
match n.t with
| `Atom _ -> n
let sub_left = function
| `Atom _ as n -> n
| `Attr (_, n) -> n
| `Join (_, a, _) -> a
let super (n : node) : node =
match n.parent with `Left n' | `Right n' -> n' | `None -> n
let sub_right = function
| `Atom _ as n -> n
| `Attr (_, n) -> n
| `Join (_, _, b) -> b
let set_children_on_parent n =
match n.parent with
| `Left ({ t = `Attr (a, _); _ } as s)
| `Right ({ t = `Attr (a, _); _ } as s) ->
s.t <- `Attr (a, n);
n
| `Left ({ t = `Join (d, _, b); _ } as s) ->
s.t <- `Join (d, n, b);
n
| `Right ({ t = `Join (d, a, _); _ } as s) ->
s.t <- `Join (d, a, n);
n
| _ -> n
let option_of_parent = function
| `None -> None
| `Left a | `Right a -> Some a
let node (t : t) =
set_parent_on_children { parent = `None; t; n = node_n () }
let atom (a : atom) = node (`Atom a)
let attr (a : attr) (child : node) = node (`Attr (a, child))
let join (d : dir) (a : node) (b : node) = node (`Join (d, a, b))
let empty_image = V2.zero
let empty_node () = node (`Atom `Empty)
let style (s : Style.t) (n : node) = node (`Attr (`Style s, n))
let atom (a : atom) : t = `Atom a
let attr (a : attr) (child : t) : t = `Attr (a, child)
let join (d : dir) (a : t) (b : t) : t = `Join (d, a, b)
let empty = `Atom `Empty
let style (s : Style.t) t = attr (`Style s) t
let pad v n = attr (`Pad (Pad.all v)) n
let rec node_up_ (d : [ `Left | `Right ]) n' =
match (d, n'.parent) with
| _, `None -> None
| ( _,
( `Left ({ t = `Attr _; _ } as p)
| `Right ({ t = `Attr _; _ } as p) ) ) ->
node_up_ d p
| `Right, `Right ({ t = `Join _; _ } as p)
| `Left, `Left ({ t = `Join _; _ } as p) ->
node_up_ d p
| `Left, `Right { t = `Join (_, l, _); _ } -> Some l
| `Right, `Left { t = `Join (_, _, r); _ } -> Some r
| _, (`Left { t = `Atom _; _ } | `Right { t = `Atom _; _ }) ->
assert false
(* left child, right sibiling *)
let rec fold_preorder : ('a -> t -> 'a option) -> 'a -> t -> 'a
=
fun f acc n ->
match f acc n with
| Some acc' -> (
match n with
| `Atom _ -> acc'
| `Attr (_, n'') -> fold_preorder f acc' n''
| `Join (_, a, b) ->
fold_preorder f (fold_preorder f acc' a) b)
| None -> acc
let node_next_ (d : [ `Left | `Right ]) (n : node) =
match (d, n.t) with
| _, `Atom _ -> node_up_ d n
| _, `Attr (_, n') -> Some n'
| `Right, `Join (_, _, r) -> Some r
| `Left, `Join (_, l, _) -> Some l
(* let rec fold_inorder : ('a -> node -> 'a option) -> 'a -> node -> 'a =
fun f acc n ->
match n with
| `Atom _ -> (match f acc n with
Some acc' -> acc'
| None -> acc)
| `Attr (_, n') ->
let acc' = (fold_inorder f acc n') in
(match f acc' n with
| Some acc'' -> acc''
| None -> acc')
| `Join (_, a, b) ->
fold_inorder f (f (fold_inorder f acc a) n) b
let rec search_preorder (f : node -> 'a option) (n : node) :
'a option =
match f n with
| None -> (
match node_next_ `Left n with
| Some n -> search_preorder f n
| None -> None)
| x -> x
let rec search_reverse_preorder (f : node -> 'a option) (n : node)
: 'a option =
match f n with
| None -> (
match node_next_ `Right n with
| Some n -> search_reverse_preorder f n
| None -> None)
| x -> x
let replace_parents_child parent n : node =
match parent with
| `Left ({ t = `Attr (a, _); _ } as p)
| `Right ({ t = `Attr (a, _); _ } as p) ->
p.t <- `Attr (a, n);
n
| `Left ({ t = `Join (d, _, r); _ } as p) ->
p.t <- `Join (d, n, r);
n
| `Right ({ t = `Join (d, l, _); _ } as p) ->
p.t <- `Join (d, l, n);
n
| _ -> n
let rec tree_iter f n i =
if i <> 0 then tree_iter f (f n) (i - 1) else f n
let search_forward f (n : node) = search_preorder f n
let search_backward f (n : node) = search_reverse_preorder f n
let rec fold_postorder : ('a -> node -> 'a option) -> 'a -> node -> 'a =
fun f acc n ->
match n with
| `Atom _ -> f (Some acc) n
| `Attr (_, n') -> f (fold_postorder f (Some acc) n') n
| `Join (_, a, b) ->
f (fold_postorder f (fold_postorder f (Some acc) a) b) n*)
let is_atom_uchar = function
| { t = `Atom (`Uchar _); _ } as n -> Some n
| `Atom (`Uchar _) as n -> Some n
| _ -> None
let tree_uchar_fwd n =
Option.value (search_forward is_atom_uchar n) ~default:n
let tree_uchar_back n =
Option.value (search_backward is_atom_uchar n) ~default:n
let is_boundary b n =
match (b, n.t) with
| `Char, `Atom (`Uchar _)
let is_boundary b t =
match (b, t) with
| ( `Char, `Atom (`Uchar _)
| `Word, `Atom (`Boundary `Word)
| `Phrase, `Atom (`Boundary `Phrase)
| `Line, `Atom (`Boundary `Line)
| `Page, `Atom (`Boundary `Page) ->
Some n
| `Page, `Atom (`Boundary `Page) ) as x ->
Some x
| _ -> None
let search_back_opt (f : node -> node option) (n : node option) =
Option.bind n (search_backward f)
let search_back_uchar_opt = search_back_opt is_atom_uchar
let rec traverse_nodes ~(f : node -> node option) (n : node) :
unit =
match f n with
| Some { t = `Atom _; _ } -> ()
| Some { t = `Attr (_, n'); _ } -> traverse_nodes ~f n'
| Some { t = `Join (_, a, b); _ } ->
traverse_nodes ~f a;
traverse_nodes ~f b
| None -> ()
let insert_join_l (d : dir) (n : node) (n' : node) : node =
let p = n.parent in
let n'' = join d n' n in
n''.parent <- p;
set_children_on_parent n''
let remove_join_l (n : node) : node =
match n.parent with
| `Left ({ t = `Attr (_, n'); _ } as s)
| `Right ({ t = `Attr (_, n'); _ } as s)
| `Left ({ t = `Join (_, _, n'); _ } as s) ->
s.t <- n'.t;
n'
| _ -> n
let kill_backward_char (n : node) : node option =
search_forward is_atom_uchar
(replace_parents_child (super (tree_uchar_back n)).parent n)
let insert_attr (a : attr) (n : node) : node =
let p = n.parent in
let n' = node (`Attr (a, n)) in
n'.parent <- p;
set_children_on_parent n'
let remove_attr (n : node) : node =
match n.t with
| `Attr (_, n') ->
(match n.parent with
| `Left ({ t = `Join (d, _, b); _ } as p) ->
p.t <- `Join (d, n', b);
ignore (set_parent_on_children p)
| `Right ({ t = `Join (d, a, _); _ } as p) ->
p.t <- `Join (d, a, n');
ignore (set_parent_on_children p)
| `Left ({ t = `Attr (a, _); _ } as p)
| `Right ({ t = `Attr (a, _); _ } as p) ->
p.t <- `Attr (a, n');
ignore (set_parent_on_children p)
| _ -> ());
n'
| _ -> assert false
let join_x = join `X
let join_y = join `Y
let join_z = join `Z
let ( ^^ ) = join_x
let ( ^/^ ) = join_y
let ( ^*^ ) = join_z
let append_ d (l : node -> node) (a : node) : node -> node =
fun n -> l (join d a n)
module Text = struct
let append_ d (l : t -> t) (a : t) (b : t) : t =
l (join d a b)
let empty_append = Fun.id
let append_x = append_ `X
let append_y = append_ `Y
let append_z = append_ `Z
module Pp = struct
let pp_uchar ppf v =
if Uchar.is_char v then Fmt.pf ppf "'%c'" (Uchar.to_char v)
else Fmt.Dump.uchar ppf v
let pp_boundary ppf v =
F.any
(match v with
| `Char -> "`Char"
| `Word -> "`Word"
| `Phrase -> "`Phrase"
| `Line -> "`Line"
| `Page -> "`Page"
| `Text ->
"`Text"
(* text is like a file (unicode calls it End Of Text) *))
ppf ()
let pp_atom ppf v =
let open Fmt in
(match v with
| `Image _ -> any "`Image"
| `Uchar c -> any "`Uchar " ++ const pp_uchar c
| `Boundary b -> any "`Boundary " ++ const pp_boundary b
| `Hint h ->
any "`Hint "
++ any
(match h with
| `Line -> "`Line"
| `Other -> "`Other")
| `Empty -> any "`Empty")
ppf ()
let pp_attr ppf v =
let open Fmt in
(any
(match v with
| `Style _ -> "`Style ..."
| `Pad _ -> "`Pad ..."
| `Shift _ -> "`Shift ..."
| `Cursor -> "`Cursor"
| `Handler _ -> "`Handler ..."
| `Draw _ -> "`Draw ..."))
ppf ()
let pp_dir ppf v =
F.pf ppf "%s"
(match v with `X -> "`X" | `Y -> "`Y" | `Z -> "`Z")
let pp_node_n ppf v = F.(pf ppf "%a" int v.n)
let rec _pp_t child ppf v =
let open Fmt in
match v with
| `Atom x -> pf ppf "`Atom %a" pp_atom x
| `Attr (a, n) ->
pf ppf "`Attr %a"
(parens (const pp_attr a ++ comma ++ const child n))
()
| `Join (d, a, b) ->
pf ppf "`Join %a"
(parens
(const pp_dir d ++ comma ++ const child a ++ comma
++ const child b))
()
and _pp_parent ppf v =
let open Fmt in
match v with
| `None -> pf ppf "`None"
| `Left n -> pf ppf "`Left %a" pp_node_n n
| `Right n -> pf ppf "`Right %a" pp_node_n n
and _pp_node child ppf v =
let open Fmt in
pf ppf "@[<hov>%a@]"
(braces
(record
[
field "n" (fun v -> v.n) int;
field "t" (fun v -> v.t) (_pp_t child);
field "parent" (fun v -> v.parent) _pp_parent;
]))
v
and pp_node_n_record =
F.(
braces
(record ~sep:semi
[ field "n" Fun.id pp_node_n; any "..." ]))
and pp_node ppf = _pp_node pp_node_n ppf
and pp_dump_node ppf = _pp_node pp_dump_node ppf
let pp_t ppf = F.pf ppf "@[<hov>%a@]" (_pp_t pp_node_n_record)
let pp_n ppf n =
F.pf ppf "@[<h>%a: %a@]" pp_node_n n (_pp_t pp_node_n) n.t
let rec pp_node_structure ppf v =
F.(
const int v.n
++ parens
(concat ~sep:comma
(match v.t with
| `Atom a -> [ const pp_atom a ]
| `Attr (a, n) ->
[ const pp_attr a; const pp_node_structure n ]
| `Join (d, l, r) ->
[
const pp_dir d;
const pp_node_structure l;
const pp_node_structure r;
])))
ppf ()
end
open Pp
module Text = struct
let rec decode dec (l : 'a) :
'a * [< `Await | `End | `Uchar of Uchar.t ] =
match Uutf.decode dec with
@ -1352,7 +1112,8 @@ module Panel = struct
and _of_string dec l =
match decode dec l with
| l, `End -> l (atom (`Boundary `Text))
| l, `Uchar c -> _of_string dec (append_x l (atom (`Uchar c)))
| l, `Uchar c ->
_of_string dec (append_x l (atom (`Uchar c)))
| l, _ -> _of_string dec l
and of_string str =
@ -1388,15 +1149,15 @@ module Panel = struct
end
module Draw = struct
open NVG
type p = P2.t
type d = [ `X | `Y | `Z ]
type t = draw_context
let vcat d a b =
match d with
| `X ->
V2.v (V2.x a +. V2.x b) (Float.max_num (V2.y a) (V2.y b))
V2.v
(V2.x a +. V2.x b)
(Float.max_num (V2.y a) (V2.y b))
| `Y ->
V2.v (Float.max_num (V2.x a) (V2.x b)) (V2.y a +. V2.y b)
| `Z ->
@ -1426,8 +1187,7 @@ module Panel = struct
(P2.y t +. metrics.ascender +. metrics.descender
+. metrics.line_height)
let rec atom vg b (a : atom) : P2.t =
let vg = vg.vg in
let rec atom { vg; _ } b (a : atom) : P2.t =
match a with
| `Image image ->
let wi, hi = Image.size vg image in
@ -1478,21 +1238,137 @@ module Panel = struct
(Float.max_num (V2.x av) (V2.x bv))
(Float.max_num (V2.y av) (V2.y bv))
and node t b (n : node) : P2.t =
and node vg b n : P2.t =
let b' =
match n.t with
| `Atom a -> atom t b a
| `Attr a -> attr t b a
| `Join a -> join t b a
match n with
| `Atom a -> atom vg b a
| `Attr a -> attr vg b a
| `Join a -> join vg b a
in
(*ignore
(Display.path_box t.vg
(Color.rgbaf ~r:1. ~g:0. ~b:0. ~a:0.2)
(Box2.of_pts b b') ) ; *)
ignore
(path_box vg.vg
(NVG.Color.rgbaf ~r:1. ~g:0. ~b:0. ~a:0.2)
(Box2.of_pts b b'));
b'
end
module Pp = struct
let pp_uchar ppf v =
if Uchar.is_char v then Fmt.pf ppf "'%c'" (Uchar.to_char v)
else Fmt.Dump.uchar ppf v
let pp_boundary ppf v =
F.any
(match v with
| `Char -> "`Char"
| `Word -> "`Word"
| `Phrase -> "`Phrase"
| `Line -> "`Line"
| `Page -> "`Page"
| `Text ->
"`Text"
(* text is like a file (unicode calls it End Of Text) *))
ppf ()
let pp_atom ppf v =
let open Fmt in
(match v with
| `Image _ -> any "`Image"
| `Uchar c -> any "`Uchar " ++ const pp_uchar c
| `Boundary b -> any "`Boundary " ++ const pp_boundary b
| `Hint h ->
any "`Hint "
++ any
(match h with
| `Line -> "`Line"
| `Other -> "`Other")
| `Empty -> any "`Empty")
ppf ()
let pp_attr ppf v =
let open Fmt in
(any
(match v with
| `Style _ -> "`Style"
| `Pad _ -> "`Pad"
| `Shift _ -> "`Shift"
| `Cursor -> "`Cursor"
| `Handler _ -> "`Handler"
| `Draw _ -> "`Draw"))
ppf ()
let pp_dir ppf v =
F.pf ppf "%s"
(match v with `X -> "`X" | `Y -> "`Y" | `Z -> "`Z")
let rec _pp_t child ppf v =
let open Fmt in
match v with
| `Atom x -> pf ppf "`Atom %a" pp_atom x
| `Attr (a, n) ->
pf ppf "`Attr %a"
(F.pair (const pp_attr a) (const child n))
(a, n)
| `Join (d, a, b) ->
pf ppf "`Join %a"
(parens
(const pp_dir d ++ comma ++ const child a ++ comma
++ const child b))
()
and pp_node ppf = _pp_t pp_node ppf
and pp_dump_node ppf = _pp_t pp_dump_node ppf
let pp_t ppf = F.pf ppf "@[<hov>%a@]" pp_node
let rec pp_node_structure ppf t =
F.(
parens
(concat ~sep:comma
(match t with
| `Atom a -> [ const pp_atom a ]
| `Attr (a, n) ->
[ const pp_attr a; const pp_node_structure n ]
| `Join (d, l, r) ->
[
const pp_dir d;
const pp_node_structure l;
const pp_node_structure r;
])))
ppf ()
let pp_step ppf s =
F.any
(match s with
| `Next -> "`Next"
| `Left -> "`Left"
| `Right -> "`Right")
ppf ()
let rec pp_path ppf (p : path) = F.list pp_step ppf p
end
end
type node = Page.t
type t = node Lwd.t
let empty = Lwd.pure Page.empty
let pad v = Lwd.map ~f:(Page.pad v)
let join d = Lwd.map2 ~f:(Page.join d)
let join_x, join_y, join_z = (join `X, join `Y, join `Z)
let ( ^^ ) = join_x
let ( ^/^ ) = join_y
let ( ^*^ ) = join_z
let pack d = Lwd_utils.lift_monoid Page.(empty, join d)
let pack_x, pack_y, pack_z = (pack `X, pack `Y, pack `Z)
let cat d = Lwd_utils.reduce (pack d)
let hcat, vcat, zcat = (cat `X, cat `Y, cat `Z)
open Page.Pp
module Action = struct
open Page
type segment =
[ `Beginning of boundary
| `Forward of boundary
@ -1501,8 +1377,8 @@ module Panel = struct
and t =
[ `Move of segment
| `Insert of node
| `Overwrite of node
| `Insert of t
| `Overwrite of t
| `Yank of segment
| `Kill of segment
| `Ascend
@ -1560,9 +1436,11 @@ module Panel = struct
ppf ()
end
let perform_action (a : Action.t) (c : cursor) : node option =
let perform_action (a : Action.t) ({ path; root } : Page.cursor) :
node option =
match a with
| `Move (`Forward `Line) -> (
| `Move (`Forward `Line) ->
(*
let i = ref 0 in
ignore
(search_backward
@ -1572,8 +1450,8 @@ module Panel = struct
incr i;
None
| _ -> None)
c.sel);
match search_forward (is_boundary `Line) c.sel with
path);
match search_forward (is_boundary `Line) path with
| Some n' ->
Some
(tree_iter
@ -1582,9 +1460,10 @@ module Panel = struct
(search_forward (is_boundary `Char) nn)
~default:nn)
n' !i)
| None -> None)
| `Move (`Backward `Line) -> (
let i = ref 0 in
| None -> *)
None
| `Move (`Backward `Line) ->
(* let i = ref 0 in
match
search_backward
(function
@ -1599,8 +1478,9 @@ module Panel = struct
Option.map
(fun n -> tree_iter tree_uchar_back n !i)
(search_backward (is_boundary `Line) n')
| None -> None)
| `Move (`Forward b) ->
| None ->*)
None
(* | `Move (`Forward b) ->
Option.map tree_uchar_fwd
(search_forward (is_boundary b) c.sel)
| `Move (`End b) ->
@ -1614,14 +1494,14 @@ module Panel = struct
(search_backward (is_boundary b) c.sel)
| `Insert n ->
ignore (insert_join_l `X (super c.sel) n);
Some c.sel
Some c.sel *)
| `Overwrite _s -> None
| `Yank _s -> None
| `Kill (`Forward `Char) -> None (*kill_forward_char c.sel *)
| `Kill (`Backward `Char) -> kill_backward_char c.sel
(* | `Kill (`Backward `Char) -> kill_backward_char c.sel *)
| `Kill _s -> None
| `Descend -> Some (sub c.sel)
| `Ascend -> option_of_parent c.sel.parent
(* | `Descend -> Some (sub c.sel) *)
(* | `Ascend -> option_of_parent c.sel.parent*)
| `Custom _s -> None
type event_status = [ `Handled | `Event of Event.t ]
@ -1663,29 +1543,43 @@ module Panel = struct
let cursor_attr =
`Style Style.(bg NVG.Color.(rgbaf ~r:1. ~g:1. ~b:0. ~a:1.))
let draw_cursor_root (c : cursor) : node =
(* this was a hack?
let draw_node_structure (doc : node Lwd.var) : node =
let open Gg in
attr
(`Draw
(fun (t : draw_context) (b : P2.t) ->
Draw.node t b
(Text.lines (Fmt.to_to_string pp_node_structure c.root))))
(atom `Empty)
(Text.lines
(Fmt.to_to_string pp_node_structure (Lwd.peek doc)))))
(atom `Empty) *)
let draw_cursor_sel (c : cursor) : node =
let open Gg in
attr
(`Draw
(fun (t : draw_context) (b : P2.t) ->
Draw.node t b
(Text.lines (Fmt.to_to_string pp_node (sub c.sel)))))
(atom `Empty)
let node_structure root =
Lwd.map
~f:(fun node ->
Page.Text.lines (Fmt.to_to_string pp_node_structure node))
root
let textedit ?(bindings = textedit_bindings) (n : node) =
let draw_path path =
Lwd.map
~f:(fun path ->
Page.Text.lines (Fmt.to_to_string pp_path path))
path
let textedit ?(bindings = textedit_bindings)
(initial : node * Page.path) =
Format.pp_set_max_boxes F.stderr 64;
(*full screen fynn *)
Format.pp_safe_set_geometry F.stderr ~max_indent:150 ~margin:230;
let bind = Key.Bind.init bindings in
let doc = Lwd.var (fst initial) in
let path = Lwd.var (snd initial) in
join_y
(pad 5. (Lwd.get doc))
(join_y
(pad 5. (draw_path (Lwd.get path)))
(pad 5. (node_structure (Lwd.get doc))))
(* let bind = Key.Bind.init bindings in
let sel = insert_attr cursor_attr n in
let c = { root = attr (`Handler (fun _ _ -> None)) sel; sel } in
c.root.t <-
@ -1725,28 +1619,30 @@ module Panel = struct
join_y (pad 5. c.root)
(join_y
(pad 5. (draw_cursor_sel c))
(pad 5. (draw_cursor_root c)))
(pad 5. (draw_cursor_root c))) *)
let handler_of_node (n : node) : handler option =
let f n =
match n.t with `Attr (`Handler f, _) -> Some f | _ -> None
in
match f n with Some a -> Some a | None -> search_forward f n
(*
let is_handler (n : node) : handler option =
match n with `Attr (`Handler f, _) -> Some f | _ -> None
(** receives a node document and event and returns a node document where that event is handled *)
let handle_event (n : t) (ev : Event.t) : t =
Lwd.map
~f:
(fold_preorder
(fun ev' n' ->
match is_handler n' with
| Some f -> f n' ev'
| None -> None)
ev)
n
let handle_event (n : node) (ev : Event.t) : event_status =
match handler_of_node n with
| Some f -> (
match f n ev with Some ev -> `Event ev | None -> `Handled)
| None -> `Event ev
let panel (vg : NVG.t) (p : P2.t) (t : node) (ev : Event.t) : P2.t
=
let panel (vg : NVG.t) (p : P2.t) (t : t) (ev : Event.t) : P2.t =
(match handle_event t ev with
| `Handled -> F.epr "Handled %s@." (Event.to_string ev)
| `Event _e ->
F.epr "Unhandled event: %s@." (Event.to_string _e));
Draw.node { vg; style = Style.dark } p t
*)
(* I feel like the Wall module from github.com/let-def/wall includes another layer on top
of the drawing functions, missing from graphv, that
specificall allows the composability and cache-ability i want, so instead of writing in from
@ -1760,6 +1656,11 @@ module Panel = struct
*
*)
module Text = struct
let lines = Lwd.map ~f:Page.Text.lines
let of_string = Lwd.map ~f:Page.Text.of_string
end
module View = struct
type path = Nav.path
@ -1772,26 +1673,11 @@ module Panel = struct
open Lwt.Infix
let pack_x = Lwd_utils.lift_monoid (empty_node (), join_x)
let pack_y = Lwd_utils.lift_monoid (empty_node (), join_y)
let pack_z = Lwd_utils.lift_monoid (empty_node (), join_z)
module DText = struct
let lines = Lwd.map ~f:Text.lines
let of_string = Lwd.map ~f:Text.of_string
end
let of_path path =
Lwd.map2 ~f:join_x
(DText.of_string (Lwd.pure "/"))
join_x
(Text.of_string (Lwd.pure "/"))
(Lwd_utils.map_reduce
(fun step ->
Lwd_utils.pack
(empty_node (), join_x)
[
DText.of_string (Lwd.pure "/");
DText.of_string (Lwd.pure step);
])
(fun step -> Lwd.pure (Page.Text.of_string ("/" ^ step)))
pack_x path)
let of_tree ?(path = []) tree =
@ -1803,39 +1689,41 @@ module Panel = struct
cursor = Lwd.var path;
doc =
Lwd_utils.map_reduce
(fun (step, _t') -> DText.of_string (Lwd.pure step))
(fun (step, _t') -> Text.of_string (Lwd.pure step))
pack_y l;
}
let list_logs hook =
let var = Lwd.var (empty_node ()) in
let var = Lwd.var Page.empty in
(hook :=
fun level s ->
Lwd.set var
(join_y
Page.(
join_y
(Text.of_string
(Logs.level_to_string (Some level) ^ ": " ^ s))
(Lwd.peek var)));
Lwd.get var
let draw (vg, p) (t : node Lwd.t) : p Lwt.t =
let draw (vg, p) (t : node Lwd.t) : Page.Draw.p Lwt.t =
let root =
Lwd.observe
~on_invalidate:(fun _ ->
Log.warn (fun m -> m "View.draw doc_root on_invalidate"))
t
in
Lwt.return (Draw.node vg p (Lwd.quick_sample root))
Lwt.return (Page.Draw.node vg p (Lwd.quick_sample root))
end
open Lwt.Infix
let render_lwt (vg : NVG.t) (p : p) (_ev : Event.t) : p Lwt.t =
let render_lwt (vg : NVG.t) (p : Gg.p2) (_ev : Event.t) :
Gg.p2 Lwt.t =
let t = { vg; style = Style.dark } in
Nav.test_pull () >>= fun tree ->
View.of_tree tree >>= fun doc ->
View.draw (t, p)
(Lwd_utils.reduce View.pack_y
(Lwd_utils.reduce pack_y
[
doc.doc;
View.of_path (Lwd.peek doc.cursor);