Compare commits
6 Commits
0d831aa9cf
...
memes
| Author | SHA1 | Date | |
|---|---|---|---|
| 50831dc73d | |||
| 98e78d81ec | |||
| fd7db32917 | |||
| c81dce7148 | |||
| 205f650eac | |||
| 8067e29ea8 |
654
human.ml
654
human.ml
@ -2,6 +2,8 @@
|
||||
|
||||
ALWAYS BREAK UP THE PROBLEM INTO SMALLER CHUNKS BITCH!!
|
||||
|
||||
Times I would have solved it faster if i broke it up instead of trying to understand it all at once: 2
|
||||
|
||||
a computation console
|
||||
|
||||
- irmin store provides a tree of data objects
|
||||
@ -1242,6 +1244,8 @@ module Panel = 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?? *)
|
||||
|
||||
(* TODO make sure this is LCRS: https://en.wikipedia.org/wiki/Left-child_right-sibling_binary_tree *)
|
||||
|
||||
open Gg
|
||||
open Wall
|
||||
|
||||
@ -1250,13 +1254,13 @@ module Panel = struct
|
||||
| `Attr of attr * node
|
||||
| `Join of dir * node * node ]
|
||||
|
||||
and node = {mutable parent: node option; mutable t: t}
|
||||
and node = {mutable parent: node option; mutable t: t; n: int}
|
||||
and cursor = {root: node; mutable sel: node}
|
||||
|
||||
and atom =
|
||||
[ `Image of image
|
||||
| `Uchar of Uchar.t
|
||||
| `Boundary of [`Word | `Line | `Sentance]
|
||||
| `Boundary of boundary
|
||||
| `Hint of [`Line | `Other]
|
||||
| `Empty ]
|
||||
|
||||
@ -1264,14 +1268,14 @@ module Panel = struct
|
||||
[ `Style of style
|
||||
| `Pad of Pad.t
|
||||
| `Shift of dim
|
||||
| `Cursor
|
||||
| `Handler of handler ]
|
||||
|
||||
and dir = [`X | `Y | `Z]
|
||||
and dim = Size2.t
|
||||
and image = Wall.image * dim
|
||||
and boundary = [`Char | `Word | `Phrase | `Line | `Page | `Text]
|
||||
and style = Style.t
|
||||
and handler = node -> Event.t -> Event.t option Lwt.t
|
||||
and dir = [`X | `Y | `Z]
|
||||
|
||||
let set_parent_on_children n : node =
|
||||
( match n.t with
|
||||
@ -1282,11 +1286,128 @@ module Panel = struct
|
||||
b.parent <- Some n ) ;
|
||||
n
|
||||
|
||||
let node (t : t) = set_parent_on_children {parent= None; t}
|
||||
let node_count = ref 0
|
||||
|
||||
let node_n () =
|
||||
node_count := !node_count + 1 ;
|
||||
!node_count - 1
|
||||
|
||||
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 = (Image.empty, V2.zero)
|
||||
let empty_node = node (`Atom `Empty)
|
||||
let empty_node () = node (`Atom `Empty)
|
||||
let style (s : Style.t) (n : node) = node (`Attr (`Style s, n))
|
||||
|
||||
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 ..." ) )
|
||||
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_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)
|
||||
(option pp_node_n) ] ) )
|
||||
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
|
||||
|
||||
let rec traverse_nodes ~(f : node -> node option) (n : node) :
|
||||
unit =
|
||||
match f n with
|
||||
@ -1321,7 +1442,8 @@ module Panel = struct
|
||||
| `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 )
|
||||
| _ -> assert false ) ;
|
||||
ignore (set_parent_on_children p)
|
||||
| None -> () ) ;
|
||||
n'
|
||||
| _ -> assert false
|
||||
@ -1332,76 +1454,23 @@ module Panel = struct
|
||||
| `Attr (_, n) -> n
|
||||
| `Join (_, a, _) -> a
|
||||
|
||||
let join_ d (a : node) (b : node) =
|
||||
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 = (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 = join `X
|
||||
let join_y = join `Y
|
||||
let join_z = join `Z
|
||||
let pack_x : node Lwd_utils.monoid = (empty_node (), join_x)
|
||||
let pack_y : node Lwd_utils.monoid = (empty_node (), join_y)
|
||||
let pack_z : node Lwd_utils.monoid = (empty_node (), join_z)
|
||||
let ( ^^ ) = join_x
|
||||
let ( ^/^ ) = join_y
|
||||
let ( ^*^ ) = join_z
|
||||
|
||||
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 append_ d (l : node -> node) (a : node) : node -> node =
|
||||
fun n -> l (join d a n)
|
||||
|
||||
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 "
|
||||
++
|
||||
match b with
|
||||
| `Word -> any "`Word"
|
||||
| `Line -> any "`Line"
|
||||
| `Sentance -> any "`Sentance" )
|
||||
| `Hint h ->
|
||||
any "`Hint "
|
||||
++ any (match h with `Line -> "`Line" | `Other -> "`Other")
|
||||
| `Empty -> any "`Empty" )
|
||||
ppf ()
|
||||
|
||||
let tess v = F.epr "%a" pp_atom v
|
||||
|
||||
let pp_attr ppf v =
|
||||
let open Fmt in
|
||||
(any
|
||||
( match v with
|
||||
| `Style _ -> "`Style ..."
|
||||
| `Pad _ -> "`Pad ..."
|
||||
| `Shift _ -> "`Shift ..."
|
||||
| `Cursor -> "`Cursor"
|
||||
| `Handler _ -> "`Handler ..." ) )
|
||||
ppf ()
|
||||
|
||||
let pp_dir ppf v =
|
||||
F.pf ppf "%s"
|
||||
(match v with `X -> "`X" | `Y -> "`Y" | `Z -> "`Z")
|
||||
|
||||
let rec pp_node ppf v =
|
||||
let open Fmt in
|
||||
pf ppf "@[<hov>%a@]" pp_t v.t
|
||||
|
||||
and pp_t ppf v =
|
||||
let open Fmt in
|
||||
match v with
|
||||
| `Join (d, a, b) ->
|
||||
pf ppf "`Join %a"
|
||||
(parens
|
||||
( const pp_dir d ++ comma ++ const pp_node a ++ comma
|
||||
++ const pp_node b ) )
|
||||
()
|
||||
| `Attr (a, n) ->
|
||||
pf ppf "`Attr %a"
|
||||
(parens (const pp_attr a ++ comma ++ const pp_node n))
|
||||
()
|
||||
| `Atom x -> pf ppf "`Atom %a" pp_atom x
|
||||
let empty_append = Fun.id
|
||||
let append_x = append_ `X
|
||||
let append_y = append_ `Y
|
||||
let append_z = append_ `Z
|
||||
|
||||
(* there's no difference between a node element and a node list what, tho an element is kinda like a node.t,
|
||||
so i guess we'll use that to kinda emulate append (vs. concat which is what join is)
|
||||
@ -1410,85 +1479,54 @@ module Panel = struct
|
||||
So i think what is really happening is that i'm defining the `list` for this node type that allows `append`.
|
||||
The main problem with this thought is that you can't do anything but append with the datastructure.
|
||||
*)
|
||||
let new_append () = empty_node
|
||||
|
||||
let append (d : dir) (l : unit -> node) (n : node) : unit -> node
|
||||
=
|
||||
fun () ->
|
||||
set_parent_on_children {parent= None; t= `Join (d, l (), n)}
|
||||
|
||||
module Text = struct
|
||||
let rec _of_string (la : unit -> node) (str : string) :
|
||||
unit -> node =
|
||||
let uudec = Uutf.decoder (`String str) in
|
||||
let rec dec (lx : unit -> node) : 'a * (unit -> node) =
|
||||
match Uutf.decode uudec with
|
||||
| `Malformed b -> dec (_of_string lx (String.escaped b))
|
||||
| (`Await | `Uchar _ | `End) as x -> (x, lx) in
|
||||
let uuline = Uuseg.create `Line_break in
|
||||
let rec new_line la' : unit -> node =
|
||||
let rec char (x, lx) (ly : unit -> node) =
|
||||
match Uuseg.add uuline x with
|
||||
| `End as x -> (ly, x)
|
||||
| `Boundary as x when Uuseg.mandatory uuline -> (ly, x)
|
||||
| `Await -> char (dec lx) ly
|
||||
let rec decode dec (l : 'a) :
|
||||
'a * [< `Await | `End | `Uchar of Uchar.t] =
|
||||
match Uutf.decode dec with
|
||||
| `Malformed b ->
|
||||
F.epr "Text.dec (Uutf.decode uudec)=`Malformed \"%s\"@."
|
||||
(String.escaped b) ;
|
||||
decode dec (append_x l (of_string (String.escaped b)))
|
||||
| (`Await | `End | `Uchar _) as s -> (l, s)
|
||||
|
||||
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, _ -> _of_string dec l
|
||||
|
||||
and of_string str =
|
||||
_of_string
|
||||
(Uutf.decoder
|
||||
~nln:(`Readline (Uchar.of_int 0x000A))
|
||||
(`String str) )
|
||||
empty_append
|
||||
|
||||
and _lines u d ly (lx, s) =
|
||||
match Uuseg.add u s with
|
||||
| `Boundary when Uuseg.mandatory u ->
|
||||
_lines u d
|
||||
(append_y ly (lx (atom (`Boundary `Line))))
|
||||
(empty_append, `Await)
|
||||
| `Boundary ->
|
||||
char
|
||||
(`Await, append `X lx (node (`Atom (`Hint `Line))))
|
||||
ly
|
||||
_lines u d ly (append_x lx (atom (`Hint `Line)), `Await)
|
||||
| `End -> ly (lx (atom (`Boundary `Text)))
|
||||
| `Await -> _lines u d ly (decode d lx)
|
||||
| `Uchar c ->
|
||||
char
|
||||
(`Await, append `X lx (node (`Atom (`Uchar c))))
|
||||
ly in
|
||||
match char (`Await, la') la' with
|
||||
| l, `Boundary ->
|
||||
new_line
|
||||
(append `Y la'
|
||||
((append `X l (node (`Atom (`Boundary `Line)))) ()) )
|
||||
| l, `End -> l in
|
||||
new_line la
|
||||
_lines u d ly (append_x lx (atom (`Uchar c)), `Await)
|
||||
|
||||
let of_string str = _of_string new_append 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 words node : node =
|
||||
segment ~boundary:`Word ~label:`Word node
|
||||
|
||||
let sentances node : node =
|
||||
segment ~boundary:`Sentence ~label:`Sentance node
|
||||
|
||||
let text str : node = insert_string str |> sentances |> words *)
|
||||
let lines str =
|
||||
_lines
|
||||
(Uuseg.create `Line_break)
|
||||
(Uutf.decoder
|
||||
~nln:(`Readline (Uchar.of_int 0x000A))
|
||||
(`String str) )
|
||||
empty_append
|
||||
(empty_append, `Await)
|
||||
end
|
||||
|
||||
let text = Text.of_string
|
||||
let text = Text.lines
|
||||
|
||||
module Draw = struct
|
||||
type d = [`X | `Y | `Z]
|
||||
@ -1537,15 +1575,15 @@ module Panel = struct
|
||||
let m = Wall_text.Font.text_measure f str in
|
||||
let v = Gg.Size2.v m.width (f.size +. f.line_height) in
|
||||
( I.stack
|
||||
(I.paint
|
||||
(Wall.Paint.color style.fg)
|
||||
(simple_text f ~valign:`TOP ~halign:`LEFT ~x:0. ~y:0.
|
||||
str ) )
|
||||
(I.paint
|
||||
(Wall.Paint.color style.bg)
|
||||
( I.fill_path
|
||||
@@ fun t ->
|
||||
P.rect t ~x:0. ~y:0. ~w:(Size2.w v) ~h:(Size2.h v) ) )
|
||||
(I.paint
|
||||
(Wall.Paint.color style.fg)
|
||||
(simple_text f ~valign:`TOP ~halign:`LEFT ~x:0. ~y:0.
|
||||
str ) )
|
||||
, v )
|
||||
|
||||
let cat d (ai, av) (bi, bv) =
|
||||
@ -1566,35 +1604,31 @@ module Panel = struct
|
||||
| `Hint _ -> empty_image
|
||||
| `Empty -> empty_image
|
||||
|
||||
and attr ?(style = Style.empty) (attr, node) : image =
|
||||
match attr with
|
||||
| `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 attr ?(style = Style.empty) (a, n) : image =
|
||||
match a with
|
||||
| `Style s -> node ~style:(Style.merge s style) n
|
||||
| `Pad p -> pad p (node ~style n)
|
||||
| `Shift s -> shift s (node ~style n)
|
||||
| _ -> node ~style n
|
||||
|
||||
and join ?(style = Style.empty) (d, a, b) : image =
|
||||
cat d (pane ~style a) (pane ~style b)
|
||||
cat d (node ~style a) (node ~style b)
|
||||
|
||||
and pane ?(style = Style.empty) (node : node) : image =
|
||||
match node.t with
|
||||
and node ?(style = Style.empty) (n : node) : image =
|
||||
match n.t with
|
||||
| `Atom a -> atom ~style a
|
||||
| `Attr a -> attr ~style a
|
||||
| `Join a -> join ~style a
|
||||
end
|
||||
|
||||
module Action = struct
|
||||
type segment_type =
|
||||
[`Char | `Word | `Phrase | `Line | `Page | `Region]
|
||||
|
||||
type segment =
|
||||
[ `Beginning of segment_type
|
||||
| `Back of segment_type
|
||||
| `Forward of segment_type
|
||||
| `End of segment_type ]
|
||||
[ `Beginning of boundary
|
||||
| `Forward of boundary
|
||||
| `Backward of boundary
|
||||
| `End of boundary ]
|
||||
|
||||
type t =
|
||||
and t =
|
||||
[ `Move of segment
|
||||
| `Yank of segment
|
||||
| `Kill of segment
|
||||
@ -1602,7 +1636,7 @@ module Panel = struct
|
||||
| `Descend
|
||||
| `Custom of string * (node -> t Key.Bind.t -> unit Lwt.t) ]
|
||||
|
||||
type dir =
|
||||
and dir =
|
||||
[ `Next
|
||||
| `Prev
|
||||
| `Up
|
||||
@ -1613,45 +1647,174 @@ module Panel = struct
|
||||
| `Enter
|
||||
| `In
|
||||
| `Out ]
|
||||
|
||||
open Fmt
|
||||
|
||||
let pp_dir ppf v =
|
||||
any
|
||||
( match v with
|
||||
| `Next -> "`Next"
|
||||
| `Prev -> "`Prev"
|
||||
| `Up -> "`Up"
|
||||
| `Down -> "`Down"
|
||||
| `Left -> "`Left"
|
||||
| `Right -> "`Right"
|
||||
| `Fwd -> "`Fwd"
|
||||
| `Enter -> "`Enter"
|
||||
| `In -> "`In"
|
||||
| `Out -> "`Out" )
|
||||
ppf ()
|
||||
|
||||
let pp_segment ppf v =
|
||||
( match v with
|
||||
| `Beginning s -> any "`Beginning " ++ const pp_boundary s
|
||||
| `Forward s -> any "`Forward " ++ const pp_boundary s
|
||||
| `Backward s -> any "`Backward " ++ const pp_boundary s
|
||||
| `End s -> any "`End " ++ const pp_boundary s )
|
||||
ppf ()
|
||||
|
||||
let pp_t ppf v =
|
||||
( match v with
|
||||
| `Move s -> any "`Move " ++ const pp_segment s
|
||||
| `Yank s -> any "`Yank " ++ const pp_segment s
|
||||
| `Kill s -> any "`Kill " ++ const pp_segment s
|
||||
| `Ascend -> any "`Ascend"
|
||||
| `Descend -> any "`Descend"
|
||||
| `Custom (s, _) ->
|
||||
fun ppf () -> pf ppf "`Custom \"%a\"" string s )
|
||||
ppf ()
|
||||
end
|
||||
|
||||
let rec search_forward (n : node) (f : node -> 'a option) :
|
||||
'a option =
|
||||
match f n with
|
||||
| None -> (
|
||||
let tree_next (n : node) =
|
||||
let rec next_right n' =
|
||||
match n'.parent with
|
||||
| None -> None
|
||||
| Some ({t= `Attr _; _} as p) -> next_right p
|
||||
| Some {t= `Join (_, a, b); _} when n' == a -> Some b
|
||||
| Some ({t= `Join (_, _, b); _} as p) when n' == b ->
|
||||
next_right p
|
||||
| Some {t= `Join _; _} -> assert false
|
||||
| Some {t= `Atom _; _} -> assert false in
|
||||
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
|
||||
| `Atom _ -> next_right n
|
||||
| `Attr (_, n') -> Some n'
|
||||
| `Join (_, a, _) -> Some a
|
||||
|
||||
let rec search_backward (n : node) (f : node -> 'a option) :
|
||||
'a option =
|
||||
match f n with
|
||||
| None -> (
|
||||
let tree_prev (n : node) =
|
||||
let rec prev_right n' =
|
||||
match n'.t with
|
||||
| `Attr (_, nn) -> prev_right nn
|
||||
| `Join (_, _, b) -> prev_right b
|
||||
| `Atom _ -> Some n' in
|
||||
match n.parent with
|
||||
| None -> None (* at root and didn't find anything *)
|
||||
| Some n -> search_backward n f )
|
||||
| Some n' -> Some n'
|
||||
| None -> None
|
||||
| Some {t= `Atom _; _} ->
|
||||
assert false
|
||||
(* shouldn't happen TODO is there no way to type constrain these? *)
|
||||
| Some {t= `Attr _; _} -> n.parent
|
||||
| Some {t= `Join (_, a, b); _} when b == n -> prev_right a
|
||||
| Some {t= `Join (_, a, _); _} when a == n -> n.parent
|
||||
| Some {t= `Join _; _} -> assert false
|
||||
(* shouldn't happen *)
|
||||
|
||||
let perform_action (a : Action.t) (c : node) : node =
|
||||
let rec tree_iter f n i =
|
||||
if i <> 0 then tree_iter f (f n) (i - 1) else f n
|
||||
|
||||
let rec search_ next f n =
|
||||
F.epr "search_ " ;
|
||||
match next n with
|
||||
| Some n' -> (
|
||||
F.epr "%a@." pp_n n' ;
|
||||
match f n' with
|
||||
| Some a -> (n', Some a)
|
||||
| None -> search_ next f n' )
|
||||
| None -> F.epr "None@." ; (n, None)
|
||||
|
||||
let search_forward f (n : node) = snd (search_ tree_next f n)
|
||||
let search_backward f (n : node) = snd (search_ tree_prev f n)
|
||||
|
||||
let is_atom_uchar = function
|
||||
| {t= `Atom (`Uchar _); _} as n -> Some n
|
||||
| _ -> None
|
||||
|
||||
let tree_uchar_fwd n =
|
||||
match is_atom_uchar n with
|
||||
| Some a -> a
|
||||
| None ->
|
||||
Option.value (search_forward is_atom_uchar n) ~default:n
|
||||
|
||||
let tree_uchar_back n =
|
||||
match is_atom_uchar n with
|
||||
| Some a -> a
|
||||
| None ->
|
||||
Option.value (search_backward is_atom_uchar n) ~default:n
|
||||
|
||||
let perform_action (a : Action.t) (c : cursor) : node option =
|
||||
let mb ?(f = fun a -> a) b n =
|
||||
match (b, n.t) with
|
||||
| `Char, `Atom (`Uchar _)
|
||||
|`Word, `Atom (`Boundary `Word)
|
||||
|`Phrase, `Atom (`Boundary `Phrase)
|
||||
|`Line, `Atom (`Boundary `Line)
|
||||
|`Page, `Atom (`Boundary `Page) ->
|
||||
Some (f n)
|
||||
| _ -> None in
|
||||
match a with
|
||||
| `Move (`Beginning `Char) -> c
|
||||
| `Move (`Beginning `Word) ->
|
||||
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
|
||||
| `Move (`Forward `Line) -> (
|
||||
let i = ref 0 in
|
||||
ignore
|
||||
(search_backward
|
||||
(function
|
||||
| {t= `Atom (`Boundary `Line); _} -> Some ()
|
||||
| {t= `Atom (`Uchar _); _} -> incr i ; None
|
||||
| _ -> None )
|
||||
c.sel ) ;
|
||||
match search_forward (mb `Line) c.sel with
|
||||
| Some n' ->
|
||||
Some
|
||||
(tree_iter
|
||||
(fun nn ->
|
||||
Option.value
|
||||
(search_forward (mb `Char) nn)
|
||||
~default:nn )
|
||||
n' !i )
|
||||
| None -> None )
|
||||
| `Move (`Backward `Line) -> (
|
||||
let i = ref 0 in
|
||||
match
|
||||
search_backward
|
||||
(function
|
||||
| {t= `Atom (`Boundary `Line); _} as n' -> Some n'
|
||||
| {t= `Atom (`Uchar _); _} -> incr i ; None
|
||||
| _ -> None )
|
||||
c.sel
|
||||
with
|
||||
| Some n' ->
|
||||
Some
|
||||
(tree_iter
|
||||
(fun nn ->
|
||||
Option.value
|
||||
(search_forward (mb `Char) nn)
|
||||
~default:nn )
|
||||
(fst (search_ tree_prev (mb `Line) n'))
|
||||
!i )
|
||||
| None -> None )
|
||||
| `Move (`Forward b) ->
|
||||
search_forward (mb ~f:tree_uchar_back b) c.sel
|
||||
| `Move (`Backward b) ->
|
||||
search_backward (mb ~f:tree_uchar_fwd b) c.sel
|
||||
| `Move (`Beginning b) ->
|
||||
(* uses last searched node regardless of match *)
|
||||
Some (tree_uchar_fwd (fst (search_ tree_prev (mb b) c.sel)))
|
||||
| `Move (`End b) ->
|
||||
(* uses last searched node regardless of match *)
|
||||
Some
|
||||
(tree_uchar_back (fst (search_ tree_next (mb b) c.sel)))
|
||||
| `Yank _s -> None
|
||||
| `Kill _s -> None
|
||||
| `Descend -> Some (sub c.sel)
|
||||
| `Ascend -> c.sel.parent
|
||||
| `Custom _s -> None
|
||||
|
||||
type event_status = [`Handled | `Event of Event.t]
|
||||
|
||||
@ -1659,57 +1822,70 @@ module Panel = struct
|
||||
let open Key.Bind in
|
||||
empty
|
||||
|> add [([Ctrl], C 'f')] [`Move (`Forward `Char)]
|
||||
|> add [([Ctrl], C 'b')] [`Move (`Back `Char)]
|
||||
|> add [([Ctrl], C 'f')] [`Move (`Forward `Word)]
|
||||
|> add [([Meta], C 'b')] [`Move (`Back `Word)]
|
||||
|> add [([Ctrl], C 'b')] [`Move (`Backward `Char)]
|
||||
|> add [([Meta], C 'f')] [`Move (`Forward `Word)]
|
||||
|> add [([Meta], C 'b')] [`Move (`Backward `Word)]
|
||||
|> add
|
||||
[([Ctrl], C 'c'); ([Ctrl], C 'n')]
|
||||
[`Move (`Forward `Phrase)]
|
||||
|> add [([Ctrl], C 'c'); ([Ctrl], C 'p')] [`Move (`Back `Phrase)]
|
||||
|> add
|
||||
[([Ctrl], C 'c'); ([Ctrl], C 'p')]
|
||||
[`Move (`Backward `Phrase)]
|
||||
|> add [([Ctrl], C 'n')] [`Move (`Forward `Line)]
|
||||
|> add [([Ctrl], C 'p')] [`Move (`Back `Line)]
|
||||
|> add [([Meta], C 'v')] [`Move (`Forward `Page)]
|
||||
|> add [([Ctrl], C 'v')] [`Move (`Back `Page)]
|
||||
|> add [([Ctrl], C 'p')] [`Move (`Backward `Line)]
|
||||
|> add [([Ctrl], C 'v')] [`Move (`Forward `Page)]
|
||||
|> add [([Meta], C 'v')] [`Move (`Backward `Page)]
|
||||
|> add [([Ctrl], C 'a')] [`Move (`Beginning `Line)]
|
||||
|> add [([Ctrl], C 'e')] [`Move (`End `Line)]
|
||||
|> add [([Ctrl], C 'k')] [`Kill (`End `Line)]
|
||||
|> add [([Ctrl], U `Backspace)] [`Kill (`Back `Word)]
|
||||
|> add [([Meta], U `Backspace)] [`Kill (`Back `Word)]
|
||||
|> add [([Ctrl], U `Backspace)] [`Kill (`Backward `Word)]
|
||||
|> add [([Meta], U `Backspace)] [`Kill (`Backward `Word)]
|
||||
|> add
|
||||
[([Ctrl], C 'x'); ([], U `Backspace)]
|
||||
[`Kill (`Back `Phrase)]
|
||||
[`Kill (`Backward `Phrase)]
|
||||
|> add [([Ctrl], C 'q')] [`Ascend]
|
||||
|> add [([Ctrl], C 'e')] [`Descend]
|
||||
|> add [([Ctrl], C 'z')] [`Descend]
|
||||
|
||||
let cursor_attr = `Style Style.(bg Color.(v 1. 1. 0. 1.))
|
||||
|
||||
let textedit_handler ?(bindings = textedit_bindings) (n : node) =
|
||||
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 n' = insert_attr `Cursor n in
|
||||
let c = ref n in
|
||||
Format.(
|
||||
F.epr
|
||||
"@[<hv> F.stderr margin: %d, max_indent: %d, max_boxes: %d \
|
||||
@]@."
|
||||
(pp_get_margin F.stderr ())
|
||||
(pp_get_max_indent F.stderr ())
|
||||
(pp_get_max_boxes F.stderr ())) ;
|
||||
F.epr "@[<v>%a@]@." pp_node n' ;
|
||||
node
|
||||
(`Attr
|
||||
let sel = insert_attr cursor_attr n in
|
||||
let c =
|
||||
{root= attr (`Handler (fun _ _ -> Lwt.return_none)) sel; sel}
|
||||
in
|
||||
c.root.t <-
|
||||
`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_node !c ;
|
||||
c.sel <- remove_attr c.sel ;
|
||||
(*F.epr
|
||||
"textedit_handler c.sel.n=%d@ c.root=@ @[%a@]@."
|
||||
pp_node_n c.sel pp_node_structure c.root ; *)
|
||||
( match perform_action x c with
|
||||
| Some n' ->
|
||||
F.epr "textedit action @[%a@] Success@."
|
||||
Action.pp_t x ;
|
||||
c.sel <- n'
|
||||
| None ->
|
||||
F.epr "textedit action @[%a@] Failure@."
|
||||
Action.pp_t x ) ;
|
||||
c.sel <- insert_attr cursor_attr c.sel ;
|
||||
Lwt.return_none
|
||||
| [] -> Lwt.return_some e )
|
||||
, n ) )
|
||||
, n ) ;
|
||||
set_parent_on_children c.root
|
||||
|
||||
let handler_of_node (n : node) : handler option =
|
||||
search_forward n (fun n ->
|
||||
match n.t with `Attr (`Handler f, _) -> Some f | _ -> None )
|
||||
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 handle_event (n : node) (ev : Event.t) : event_status Lwt.t =
|
||||
match handler_of_node n with
|
||||
@ -1738,23 +1914,23 @@ module Panel = struct
|
||||
() ) ;
|
||||
Lwt.return_unit )
|
||||
ev
|
||||
>|= fun () -> Draw.pane r )
|
||||
>|= fun () -> Draw.node r )
|
||||
|
||||
let test =
|
||||
panel
|
||||
(Lwd.pure
|
||||
(textedit_handler
|
||||
(style Style.dark
|
||||
(*(join_y
|
||||
(join_y
|
||||
(Text.insert_string empty_node
|
||||
(join_y
|
||||
(Text.of_string
|
||||
"-- welcome to my land of idiocy ---" )
|
||||
(join_x
|
||||
(Text.insert_string empty_node "hello bitch")
|
||||
(Text.insert_string empty_node
|
||||
"!\n sup daddy" ) ) )*)
|
||||
(Text.of_string "test 1 2 3") ) ) )
|
||||
(* ) *)
|
||||
( ( Text.of_string "hello bitch"
|
||||
^^ Text.of_string "!\n sup daddy" )
|
||||
^/^ (text "hello bitch" ^^ text "!\n sup daddy")
|
||||
^/^ text "hello bitch" ^/^ text "!\n sup daddy"
|
||||
) )
|
||||
(Text.of_string "123") ) ) ) )
|
||||
end
|
||||
end
|
||||
|
||||
|
||||
Reference in New Issue
Block a user