working on cursor contro
This commit is contained in:
cqc
554
human.ml
554
human.ml
@ -1236,109 +1236,20 @@ module Panel = struct
|
||||
; r= Gg.Size1.zero }
|
||||
end
|
||||
|
||||
module Region = struct
|
||||
type 'a t =
|
||||
{t: 'a Trope.t; left: Trope.cursor; right: Trope.cursor}
|
||||
|
||||
and 'a region = 'a t
|
||||
|
||||
type cursor = Trope.cursor
|
||||
|
||||
let create () =
|
||||
let t = Trope.create () in
|
||||
let left = Trope.cursor_at_origin t in
|
||||
{t; left; right= left}
|
||||
|
||||
let append (t : 'a region) (e : 'a) : 'a region =
|
||||
let right = Trope.cursor_after t.right in
|
||||
{t with t= Trope.put_right t.t right e; right}
|
||||
|
||||
let rec iter ~t ?(start = t.left) ~(f : 'a -> unit) () =
|
||||
match Trope.seek_after t.t start with
|
||||
| Some (c, e) -> f e ; iter ~start:c ~t ~f ()
|
||||
| None -> ()
|
||||
|
||||
let rec trope_replace ~(t : 'a region) ?(start = t.left)
|
||||
~(f :
|
||||
'a Trope.t * Trope.cursor
|
||||
-> 'a
|
||||
-> 'a Trope.t * Trope.cursor ) () : 'a region =
|
||||
match Trope.seek_after t.t start with
|
||||
| Some (c, e) ->
|
||||
let t', c' = f (t.t, c) e in
|
||||
trope_replace
|
||||
~t:
|
||||
{ t with
|
||||
t= t'
|
||||
; right=
|
||||
( if Trope.compare t.right c' < 0 then c'
|
||||
else t.right ) }
|
||||
~start:c' ~f ()
|
||||
| None -> t
|
||||
|
||||
let rec replace ~(r : 'a region) ?(start = r.left)
|
||||
~(f : 'a t * cursor -> 'a -> 'a t * cursor) () : 'a region =
|
||||
match Trope.seek_after r.t start with
|
||||
| Some (c, e) ->
|
||||
let r', c' = f (r, c) e in
|
||||
replace
|
||||
~r:
|
||||
{ r' with
|
||||
right=
|
||||
( if Trope.compare r.right c' < 0 then c'
|
||||
else r.right ) }
|
||||
~start:c' ~f ()
|
||||
| None -> r
|
||||
|
||||
let seek_before ~(r : 'a region) : 'a region option =
|
||||
match Trope.seek_before r.t r.left with
|
||||
| Some (c, _e) -> Some {r with left= c}
|
||||
| None -> None
|
||||
|
||||
let rec fold ~(t : 'a region) ?(start = t.left)
|
||||
~(f : 'a Trope.t * Trope.cursor -> 'a -> 'b -> 'b) (acc : 'b)
|
||||
: 'b =
|
||||
match Trope.seek_after t.t start with
|
||||
| Some (c, e) -> fold ~t ~start:c ~f (f (t.t, c) e acc)
|
||||
| None -> acc
|
||||
|
||||
let rec fold_lwt ~(t : 'a region) ?(start = t.left)
|
||||
~(f : 'a Trope.t * Trope.cursor -> 'a -> 'b -> 'b Lwt.t)
|
||||
(acc : 'b) : 'b Lwt.t =
|
||||
match Trope.seek_after t.t start with
|
||||
| Some (c, e) ->
|
||||
f (t.t, c) e acc >>= fun x -> fold_lwt ~t ~start:c ~f x
|
||||
| None -> Lwt.return acc
|
||||
|
||||
let rec fold_lwt_opt ~(t : 'a region) ?(start = t.left)
|
||||
~(f : 'a Trope.t * Trope.cursor -> 'a -> 'b -> 'b option Lwt.t)
|
||||
(acc : 'b) : 'b Lwt.t =
|
||||
match Trope.seek_after t.t start with
|
||||
| Some (c, e) -> (
|
||||
f (t.t, c) e acc
|
||||
>>= function
|
||||
| Some x -> fold_lwt_opt ~t ~start:c ~f x
|
||||
| None -> Lwt.return acc )
|
||||
| None -> Lwt.return acc
|
||||
end
|
||||
|
||||
(* trying to construct a data type where "regions" as above are an internal
|
||||
linear dimension inside a tree, or maybe even a dag *)
|
||||
|
||||
module Ui = struct
|
||||
(* Tree-like structure of Ui elements, from the entire display down to individual glyphs.
|
||||
Uses the linear Region.t as the collection of nodes on each branch *)
|
||||
(* 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?? *)
|
||||
|
||||
open Gg
|
||||
open Wall
|
||||
|
||||
type t =
|
||||
[`Atom of atom | `Attr of attr * node | `Region of dir * region]
|
||||
[ `Atom of atom
|
||||
| `Attr of attr * node
|
||||
| `Join of dir * node * node ]
|
||||
|
||||
and node = {mutable parent: [`Node of node | `Region of node * Region.cursor]; mutable child: t}
|
||||
and cursor = {root: node;
|
||||
mutable sel: node option;
|
||||
}
|
||||
and node = {mutable parent: node option; mutable t: t}
|
||||
and cursor = {root: node; mutable sel: node}
|
||||
|
||||
and atom =
|
||||
[ `Image of image
|
||||
@ -1349,123 +1260,135 @@ module Panel = struct
|
||||
[ `Style of style
|
||||
| `Pad of Pad.t
|
||||
| `Shift of dim
|
||||
| `Handle of handle ]
|
||||
| `Cursor
|
||||
| `Handler of handler ]
|
||||
|
||||
and region = node Region.t
|
||||
and dir = [`X | `Y | `Z]
|
||||
and image = Wall.image * Size2.t
|
||||
and dim = Gg.size2
|
||||
and dim = Size2.t
|
||||
and image = Wall.image * dim
|
||||
and style = Style.t
|
||||
and handle = node -> Event.t -> Event.t option Lwt.t
|
||||
and handler = node -> Event.t -> Event.t option Lwt.t
|
||||
and dir = [`X | `Y | `Z]
|
||||
|
||||
let empty_image = (Image.empty, V2.zero)
|
||||
|
||||
let empty_node =
|
||||
let rec parent = `Atom (`Image empty_image) in
|
||||
parent
|
||||
|
||||
let empty_region dir : t = `Region (dir, Region.create ())
|
||||
|
||||
let set_parent_on_children parent =
|
||||
match parent.child with
|
||||
let set_parent_on_children n : node =
|
||||
( match n.t with
|
||||
| `Atom _ -> ()
|
||||
| `Attr (_, n) -> n.parent <- `Node parent
|
||||
| `Region (_, r) ->
|
||||
Region.fold ~t:r ~f:(fun (_, c) n a -> n.parent <- `Region (parent, c); a) ()
|
||||
|
||||
let node (child : t) =
|
||||
let rec parent = {parent=`Node parent; child} in
|
||||
set_parent_on_children parent ;
|
||||
parent
|
||||
|
||||
let style (s : Style.t) (n : node) = node (`Attr (`Style s, n))
|
||||
|
||||
let node_func ?(fnode = fun (x : node) -> x)
|
||||
?(fregion = fun (x : node Region.t) -> x)
|
||||
?(fatom = fun (x : atom) -> x) n : node =
|
||||
n.child <-
|
||||
( match n.child with
|
||||
| `Attr (a, n) -> `Attr (a, {(fnode n) with parent=`Node n})
|
||||
| `Region (a, r) -> `Region (a, fregion r)
|
||||
| `Atom a -> `Atom (fatom a) ) ;
|
||||
| `Attr (_, a) -> a.parent <- Some n
|
||||
| `Join (_, a, b) ->
|
||||
a.parent <- Some n ;
|
||||
b.parent <- Some n ) ;
|
||||
n
|
||||
|
||||
let rec traverse_nodes ~(f : node -> node) (n : node) : node =
|
||||
node_func
|
||||
~fnode:(fun n -> traverse_nodes ~f (f n))
|
||||
~fregion:(fun r ->
|
||||
Region.replace ~r
|
||||
~f:(fun (r, c) e ->
|
||||
( { r with
|
||||
t=
|
||||
Trope.put_right r.t c
|
||||
{(traverse_nodes ~f e) with parent= `Region (n, c)} }
|
||||
, c ) )
|
||||
() )
|
||||
n
|
||||
let node (t : t) = set_parent_on_children {parent= None; t}
|
||||
let empty_image = (Image.empty, V2.zero)
|
||||
let empty_node = node (`Atom (`Image empty_image))
|
||||
let style (s : Style.t) (n : node) = node (`Attr (`Style s, n))
|
||||
|
||||
let rec traverse_regions
|
||||
~(region :
|
||||
parent:node
|
||||
-> node Region.t * Region.cursor
|
||||
-> child:node
|
||||
-> node Region.t * Region.cursor ) ~(node : node -> node)
|
||||
(parent : node) : node =
|
||||
node_func
|
||||
~fnode:(fun n -> traverse_regions ~region ~node (node n))
|
||||
~fregion:(fun r ->
|
||||
Region.replace ~r
|
||||
~f:(fun (r, c) child -> region ~parent (r, c) ~child)
|
||||
() )
|
||||
parent
|
||||
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 region_append (r : node) (c : t) : node =
|
||||
match r.child with
|
||||
`Atom _ | `Attr _ -> assert false
|
||||
| `Region (d, r') ->
|
||||
let right = Trope.cursor_after r'.right in
|
||||
let child = {parent=`Region (r, right); child=c} in
|
||||
{r with child=`Region (d,{r' with t= Trope.put_right r'.t right child; right})}
|
||||
let insert_attr (a : attr) (n : node) : node =
|
||||
let p = n.parent in
|
||||
let n' = node (`Attr (a, n)) in
|
||||
n'.parent <- p ;
|
||||
( match p with
|
||||
| Some p ->
|
||||
p.t <-
|
||||
( match p.t with
|
||||
| `Attr (a, _) -> `Attr (a, n')
|
||||
| `Join (d, a, b) when n == a -> `Join (d, n', b)
|
||||
| `Join (d, a, b) when n == b -> `Join (d, a, n')
|
||||
| _ -> assert false )
|
||||
| None -> () ) ;
|
||||
n'
|
||||
|
||||
let remove_attr (n : node) : node =
|
||||
match n.t with
|
||||
| `Attr (_, n') ->
|
||||
( match n.parent with
|
||||
| Some p ->
|
||||
p.t <-
|
||||
( match p.t with
|
||||
| `Attr (a, _) -> `Attr (a, n')
|
||||
| `Join (d, a, b) when n == a -> `Join (d, n', b)
|
||||
| `Join (d, a, b) when n == b -> `Join (d, a, n')
|
||||
| _ -> assert false )
|
||||
| None -> () ) ;
|
||||
n'
|
||||
| _ -> assert false
|
||||
|
||||
let sub (n : node) : node =
|
||||
match n.t with
|
||||
| `Atom _ -> n
|
||||
| `Attr (_, n) -> n
|
||||
| `Join (_, a, _) -> a
|
||||
|
||||
let join_ d (a : node) (b : node) =
|
||||
let rec parent =
|
||||
{ parent= `Node parent
|
||||
; child=
|
||||
`Region
|
||||
(d, Region.append (Region.append (Region.create ()) a) b)
|
||||
} in
|
||||
set_parent_on_children parent ;
|
||||
parent
|
||||
set_parent_on_children {parent= a.parent; t= `Join (d, a, b)}
|
||||
|
||||
let empty_join d = node (`Join (d, empty_node, empty_node))
|
||||
let join_x = join_ `X
|
||||
let join_y = join_ `Y
|
||||
let join_z = join_ `Z
|
||||
|
||||
let pack_x : node Lwd_utils.monoid =
|
||||
(node (empty_region `X), join_x)
|
||||
|
||||
let pack_y : node Lwd_utils.monoid =
|
||||
(node (empty_region `Y), join_y)
|
||||
|
||||
let pack_z : node Lwd_utils.monoid =
|
||||
(node (empty_region `Z), join_z)
|
||||
|
||||
let pack_x : node Lwd_utils.monoid = (empty_join `X, join_x)
|
||||
let pack_y : node Lwd_utils.monoid = (empty_join `Y, join_y)
|
||||
let pack_z : node Lwd_utils.monoid = (empty_join `Z, join_z)
|
||||
let ( ^^ ) = join_x
|
||||
let ( ^/^ ) = join_y
|
||||
|
||||
let rec pp_ui : node F.t =
|
||||
fun ppf v ->
|
||||
let atom a =
|
||||
F.pf ppf "`Atom " ;
|
||||
match a with
|
||||
| `Image _ -> F.pf ppf "`Image"
|
||||
| `Uchar c ->
|
||||
F.pf ppf "`Uchar " ;
|
||||
if Uchar.is_char c then F.pf ppf "%c" (Uchar.to_char c)
|
||||
else F.pf ppf "0x%x" (Uchar.to_int c)
|
||||
| `Boundary b ->
|
||||
F.pf ppf "`Boundary " ;
|
||||
F.pf ppf
|
||||
( match b with
|
||||
| `Word -> "`Word"
|
||||
| `Line -> "`Line"
|
||||
| `Sentance -> "`Sentance"
|
||||
| `Hint -> "`Hint" ) in
|
||||
let attr a =
|
||||
F.pf ppf "`Attr " ;
|
||||
F.pf ppf
|
||||
( match a with
|
||||
| `Style _ -> "`Style ..., "
|
||||
| `Pad _ -> "`Pad ..., "
|
||||
| `Shift _ -> "`Shift ..., "
|
||||
| `Cursor -> "`Cursor "
|
||||
| `Handler _ -> "`Handler ..., " ) in
|
||||
let join (d, a, b) =
|
||||
F.pf ppf "`Join " ;
|
||||
( match d with
|
||||
| `X -> F.pf ppf "`X "
|
||||
| `Y -> F.pf ppf "`Y "
|
||||
| `Z -> F.pf ppf "`Z " ) ;
|
||||
F.parens pp_ui ppf b ; F.parens pp_ui ppf a in
|
||||
match v.t with
|
||||
| `Join x -> join x
|
||||
| `Attr (x, n) -> attr x ; F.parens pp_ui ppf n
|
||||
| `Atom x -> atom x
|
||||
|
||||
module Text = struct
|
||||
let rec _of_string ~(ry : node) (str : string) : node =
|
||||
let rec insert_string (n : node) (str : string) : node =
|
||||
let uudec = Uutf.decoder (`String str) in
|
||||
let rec dec (rx' : node Region.t) : 'a * node Region.t =
|
||||
let rec dec (n' : node) : 'a * node =
|
||||
match Uutf.decode uudec with
|
||||
| `Malformed b ->
|
||||
dec
|
||||
(Region.append rx'
|
||||
(_of_string ~ry:(node (empty_region `Y))
|
||||
(String.escaped b) ) )
|
||||
| (`Await | `Uchar _ | `End) as x -> (x, rx') in
|
||||
| `Malformed b -> dec (insert_string n' (String.escaped b))
|
||||
| (`Await | `Uchar _ | `End) as x -> (x, n') in
|
||||
let uuline = Uuseg.create `Line_break in
|
||||
let rec line (ry' : node) : node =
|
||||
let rec line (n' : node) : node =
|
||||
let rec char (x, t) (line : node) =
|
||||
match Uuseg.add uuline x with
|
||||
| `End as x -> (line, x)
|
||||
@ -1474,69 +1397,67 @@ module Panel = struct
|
||||
| `Boundary ->
|
||||
char
|
||||
(`Await, t)
|
||||
(region_append line (`Atom (`Boundary `Hint)))
|
||||
(line ^^ node (`Atom (`Boundary `Hint)))
|
||||
| `Uchar c ->
|
||||
char
|
||||
(`Await, t)
|
||||
(region_append line (`Atom (`Uchar c) )) in
|
||||
match
|
||||
char
|
||||
(`Await, rl)
|
||||
(node (empty_region `X))
|
||||
with
|
||||
| l, `Boundary ->
|
||||
line (region_append ry' (`Atom (`Boundary `Line) ))
|
||||
| l, `End ->
|
||||
region_append ry' l in
|
||||
parent.child <- `Region (`Y, line rl) ;
|
||||
parent
|
||||
char (`Await, t) (line ^^ node (`Atom (`Uchar c)))
|
||||
in
|
||||
match char (`Await, n') n' with
|
||||
| l, `Boundary -> line (l ^/^ node (`Atom (`Boundary `Line)))
|
||||
| l, `End -> l in
|
||||
line n
|
||||
|
||||
let of_string ?(ry = (empty_region `Y)) (str : string) =
|
||||
_of_string ~ry str
|
||||
(* let segment ?(boundary = `Word) ?(label = `Word) (node : node) :
|
||||
node =
|
||||
let uuseg = Uuseg.create boundary in
|
||||
traverse_regions
|
||||
~node:(fun node -> node)
|
||||
~region:(fun ~parent (r, c) ~child ->
|
||||
match child.child with
|
||||
| `Atom (`Uchar uc) ->
|
||||
let rec seg ((t : node Trope.t), (c : Region.cursor))
|
||||
e' =
|
||||
match Uuseg.add uuseg e' with
|
||||
| `Boundary ->
|
||||
seg
|
||||
( Trope.put_right t c
|
||||
{parent; child= `Atom (`Boundary label)}
|
||||
, Trope.cursor_after c )
|
||||
`Await
|
||||
| `End | `Await -> (t, c)
|
||||
| `Uchar ch ->
|
||||
seg
|
||||
( Trope.put_right t c
|
||||
{parent; child= `Atom (`Uchar ch)}
|
||||
, c )
|
||||
`Await in
|
||||
let r', c' = seg (r.t, c) (`Uchar uc) in
|
||||
({r with t= r'}, c')
|
||||
| _ -> (r, c) )
|
||||
node
|
||||
|
||||
let segment ?(boundary = `Word) ?(label = `Word) (node : node) :
|
||||
node =
|
||||
let uuseg = Uuseg.create boundary in
|
||||
traverse_regions
|
||||
~node:(fun node -> node)
|
||||
~region:(fun ~parent (r, c) ~child ->
|
||||
match child.child with
|
||||
| `Atom (`Uchar uc) ->
|
||||
let rec seg ((t : node Trope.t), (c : Region.cursor))
|
||||
e' =
|
||||
match Uuseg.add uuseg e' with
|
||||
| `Boundary ->
|
||||
seg
|
||||
( Trope.put_right t c
|
||||
{parent; child= `Atom (`Boundary label)}
|
||||
, Trope.cursor_after c )
|
||||
`Await
|
||||
| `End | `Await -> (t, c)
|
||||
| `Uchar ch ->
|
||||
seg
|
||||
( Trope.put_right t c
|
||||
{parent; child= `Atom (`Uchar ch)}
|
||||
, c )
|
||||
`Await in
|
||||
let r', c' = seg (r.t, c) (`Uchar uc) in
|
||||
({r with t= r'}, c')
|
||||
| _ -> (r, c) )
|
||||
node
|
||||
let words node : node =
|
||||
segment ~boundary:`Word ~label:`Word node
|
||||
|
||||
let words node : node =
|
||||
segment ~boundary:`Word ~label:`Word node
|
||||
let sentances node : node =
|
||||
segment ~boundary:`Sentence ~label:`Sentance node
|
||||
|
||||
let sentances node : node =
|
||||
segment ~boundary:`Sentence ~label:`Sentance node
|
||||
|
||||
let text str : node = of_string str |> sentances |> words
|
||||
let text str : node = insert_string str |> sentances |> words *)
|
||||
end
|
||||
|
||||
let text = Text.text
|
||||
let text = Text.insert_string
|
||||
|
||||
module Draw = struct
|
||||
type d = [`X | `Y | `Z]
|
||||
|
||||
let cursor ((i, v) : image) =
|
||||
( I.stack
|
||||
(I.paint (Paint.color Color.red)
|
||||
( I.stroke_path (Outline.make ())
|
||||
@@ fun t ->
|
||||
P.rect t ~x:0. ~y:0. ~w:(V2.x v) ~h:(V2.y v) ) )
|
||||
i
|
||||
, v )
|
||||
|
||||
let vcat d a b =
|
||||
match d with
|
||||
| `X -> V2.v (V2.x a +. V2.x b) (Float.fmax (V2.y a) (V2.y b))
|
||||
@ -1604,18 +1525,17 @@ module Panel = struct
|
||||
| `Style s -> pane ~style:(Style.merge s style) node
|
||||
| `Pad p -> pad p (pane ~style node)
|
||||
| `Shift s -> shift s (pane ~style node)
|
||||
| `Cursor -> cursor (pane ~style node)
|
||||
| _ -> pane ~style node
|
||||
|
||||
and region ?(style = Style.empty) (dir, region) : image =
|
||||
Region.fold ~t:region
|
||||
~f:(fun _ n i -> cat dir i (pane ~style n))
|
||||
empty_image
|
||||
and join ?(style = Style.empty) (d, a, b) : image =
|
||||
cat d (pane ~style a) (pane ~style b)
|
||||
|
||||
and pane ?(style = Style.empty) (node : node) : image =
|
||||
match node.child with
|
||||
match node.t with
|
||||
| `Atom a -> atom ~style a
|
||||
| `Attr a -> attr ~style a
|
||||
| `Region a -> region ~style a
|
||||
| `Join a -> join ~style a
|
||||
end
|
||||
|
||||
module Action = struct
|
||||
@ -1632,6 +1552,8 @@ module Panel = struct
|
||||
[ `Move of segment
|
||||
| `Yank of segment
|
||||
| `Kill of segment
|
||||
| `Ascend
|
||||
| `Descend
|
||||
| `Custom of string * (node -> t Key.Bind.t -> unit Lwt.t) ]
|
||||
|
||||
type dir =
|
||||
@ -1647,54 +1569,44 @@ module Panel = struct
|
||||
| `Out ]
|
||||
end
|
||||
|
||||
let rec search_backward (n : node) (f : node -> 'a option) : 'a option =
|
||||
let rec search_forward (n : node) (f : node -> 'a option) :
|
||||
'a option =
|
||||
match f n with
|
||||
| None ->
|
||||
(match n.parent.child with
|
||||
| a when n = a -> None (* at root and didn't find anything *)
|
||||
| (`Atom _) | (`Attr _) -> search_backward node.parent f
|
||||
| (`Region (d, r)) -> (
|
||||
match Region.seek_before ~r with
|
||||
| Some r' ->
|
||||
search_backward {node with child= `Region (d, r')} t
|
||||
| None -> search_backward node.parent t )
|
||||
| None -> (
|
||||
match n.t with
|
||||
| `Atom _ -> None
|
||||
| `Attr (_, n) -> search_forward n f
|
||||
| `Join (_, a, b) -> (
|
||||
match search_forward a f with
|
||||
| Some n' -> Some n'
|
||||
| None -> search_forward b f ) )
|
||||
| Some a -> Some a
|
||||
|
||||
let rec search_backward (n : node) (f : node -> 'a option) :
|
||||
'a option =
|
||||
match f n with
|
||||
| None -> (
|
||||
match n.parent with
|
||||
| None -> None (* at root and didn't find anything *)
|
||||
| Some n -> search_backward n f )
|
||||
| Some n' -> Some n'
|
||||
|
||||
|
||||
let handle_action (a : Action.t) (c : node) : node option =
|
||||
let perform_action (a : Action.t) (c : node) : node =
|
||||
match a with
|
||||
| `Move (`Beginning `Char) -> c
|
||||
| `Move (`Beginning `Word) ->
|
||||
search_backward c (fun n -> match n.child with `Atom (`Boundary `Word) -> n | None -> None)
|
||||
Option.value ~default:c
|
||||
(search_backward c (fun n ->
|
||||
match n.t with
|
||||
| `Atom (`Boundary `Word) -> Some n
|
||||
| _ -> None ) )
|
||||
| `Move _ -> c
|
||||
| `Yank _s -> c
|
||||
| `Kill _s -> c
|
||||
| `Descend -> sub c
|
||||
| `Ascend -> ( match c.parent with Some n -> n | None -> c )
|
||||
| `Custom _s -> c
|
||||
|
||||
let rec handle_of_node (node : node) : handle option
|
||||
=
|
||||
traverse_nodes ~f:(fun n ->
|
||||
match n.child with
|
||||
| `Atom _ -> None
|
||||
| `Attr (`Handle f, _) -> Some f
|
||||
| `Attr (_, n) -> handle_of_node n
|
||||
| `Region (_, r) ->
|
||||
traverse_ ~t:r
|
||||
~f:(fun _ n (es : event_status) ->
|
||||
match es with
|
||||
| `Event e -> (
|
||||
handle_event n e
|
||||
>>= function
|
||||
| `Handled -> Lwt.return None
|
||||
| x -> Lwt.return (Some x) )
|
||||
| `Handled -> Lwt.return None )
|
||||
(`Event ev)
|
||||
|
||||
let action_of_handler (e : Event.t) (h : handler) = Action.t option
|
||||
f n ev
|
||||
>>= function
|
||||
| Some e -> Lwt.return `Handled | None -> Lwt.return_none )
|
||||
|
||||
type event_status = [`Handled | `Event of Event.t]
|
||||
|
||||
let textedit_bindings =
|
||||
@ -1720,58 +1632,76 @@ module Panel = struct
|
||||
|> add
|
||||
[([Ctrl], C 'x'); ([], U `Backspace)]
|
||||
[`Kill (`Back `Phrase)]
|
||||
|> add [([Ctrl], C 'q')] [`Ascend]
|
||||
|> add [([Ctrl], C 'e')] [`Descend]
|
||||
|
||||
let textedit_handler ?(bindings = textedit_bindings) (n : node) =
|
||||
let bind = Key.Bind.init bindings in
|
||||
let n' = insert_attr `Cursor n in
|
||||
let c = ref n in
|
||||
`Handler ( (fun (_ : node) (e : Event.t) : Event.t option Lwt.t ->
|
||||
match Key.Bind.resolve_events bind [e] with
|
||||
| x :: _ -> handle_event x n c
|
||||
| [] -> Lwt.return_some e )
|
||||
, Focus.make () )
|
||||
F.epr "%a@." pp_ui n' ;
|
||||
node
|
||||
(`Attr
|
||||
( `Handler
|
||||
(fun (_ : node) (e : Event.t) : Event.t option Lwt.t ->
|
||||
match Key.Bind.resolve_events bind [e] with
|
||||
| x :: _ ->
|
||||
c :=
|
||||
insert_attr `Cursor
|
||||
(perform_action x (remove_attr !c)) ;
|
||||
F.epr "%a@." pp_ui !c ;
|
||||
Lwt.return_none
|
||||
| [] -> Lwt.return_some e )
|
||||
, n ) )
|
||||
|
||||
let rec handle_event (n : cursor) (ev : Event.t) :
|
||||
event_status Lwt.t =
|
||||
match n.sel.child with
|
||||
| Some a ->
|
||||
c := handle_action a !c ;
|
||||
Lwt.return `Handled
|
||||
| None -> `Event ev
|
||||
let handler_of_node (n : node) : handler option =
|
||||
search_forward n (fun n ->
|
||||
match n.t with `Attr (`Handler f, _) -> Some f | _ -> None )
|
||||
|
||||
let handle_event (n : node) (ev : Event.t) : event_status Lwt.t =
|
||||
match handler_of_node n with
|
||||
| Some f -> (
|
||||
f n ev
|
||||
>>= function
|
||||
| Some ev -> Lwt.return (`Event ev)
|
||||
| None -> Lwt.return `Handled )
|
||||
| None -> Lwt.return (`Event ev)
|
||||
|
||||
let panel (t : node Lwd.t) : (Event.events -> image Lwt.t) Lwt.t =
|
||||
let rq = Lwd.make_release_queue () in
|
||||
let root = Lwd.observe t in
|
||||
Lwt.return (fun ev ->
|
||||
let r = Lwd.sample rq root in
|
||||
(* F.epr "Draw.pane: %a@." pp_ui r ; *)
|
||||
Lwt_list.iter_s
|
||||
(fun e ->
|
||||
handle_event r e c
|
||||
handle_event r e
|
||||
>>= fun h ->
|
||||
( match h with
|
||||
| `Handled -> ()
|
||||
| `Event e ->
|
||||
F.epr "handle_event: Unhandled event: %s@."
|
||||
(Event.to_string e) ) ;
|
||||
| `Handled -> F.epr "Handled %s@." (Event.to_string e)
|
||||
| `Event _e ->
|
||||
(* F.epr "Unhandled event: %s@."
|
||||
(Event.to_string _e)*)
|
||||
() ) ;
|
||||
Lwt.return_unit )
|
||||
ev
|
||||
>|= fun () -> Draw.pane r )
|
||||
|
||||
let new_cursor (root : node) : cursor =
|
||||
{root; sel=root}
|
||||
|
||||
let test =
|
||||
panel
|
||||
(Lwd.pure
|
||||
(textedit_handler
|
||||
(style Style.dark
|
||||
(join_y
|
||||
(*(join_y
|
||||
(join_y
|
||||
(Text.of_string
|
||||
(Text.insert_string empty_node
|
||||
"-- welcome to my land of idiocy ---" )
|
||||
(join_x
|
||||
(Text.of_string "hello bitch")
|
||||
(Text.of_string "!\n sup dude") ) )
|
||||
(Text.of_string "test 1 2 3 4 5 6") ) ) ) )
|
||||
(Text.insert_string empty_node "hello bitch")
|
||||
(Text.insert_string empty_node
|
||||
"!\n sup daddy" ) ) )*)
|
||||
(Text.insert_string empty_node "test 1 2 3") ) ) )
|
||||
(* ) *)
|
||||
end
|
||||
end
|
||||
|
||||
|
||||
Reference in New Issue
Block a user