Compare commits
3 Commits
c81dce7148
...
memes
| Author | SHA1 | Date | |
|---|---|---|---|
| 50831dc73d | |||
| 98e78d81ec | |||
| fd7db32917 |
564
human.ml
564
human.ml
@ -1260,7 +1260,7 @@ module Panel = struct
|
|||||||
and atom =
|
and atom =
|
||||||
[ `Image of image
|
[ `Image of image
|
||||||
| `Uchar of Uchar.t
|
| `Uchar of Uchar.t
|
||||||
| `Boundary of [`Word | `Line | `Sentance]
|
| `Boundary of boundary
|
||||||
| `Hint of [`Line | `Other]
|
| `Hint of [`Line | `Other]
|
||||||
| `Empty ]
|
| `Empty ]
|
||||||
|
|
||||||
@ -1273,6 +1273,7 @@ module Panel = struct
|
|||||||
and dir = [`X | `Y | `Z]
|
and dir = [`X | `Y | `Z]
|
||||||
and dim = Size2.t
|
and dim = Size2.t
|
||||||
and image = Wall.image * dim
|
and image = Wall.image * dim
|
||||||
|
and boundary = [`Char | `Word | `Phrase | `Line | `Page | `Text]
|
||||||
and style = Style.t
|
and style = Style.t
|
||||||
and handler = node -> Event.t -> Event.t option Lwt.t
|
and handler = node -> Event.t -> Event.t option Lwt.t
|
||||||
|
|
||||||
@ -1294,10 +1295,119 @@ module Panel = struct
|
|||||||
let node (t : t) =
|
let node (t : t) =
|
||||||
set_parent_on_children {parent= None; t; n= node_n ()}
|
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_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))
|
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) :
|
let rec traverse_nodes ~(f : node -> node option) (n : node) :
|
||||||
unit =
|
unit =
|
||||||
match f n with
|
match f n with
|
||||||
@ -1344,13 +1454,9 @@ module Panel = struct
|
|||||||
| `Attr (_, n) -> n
|
| `Attr (_, n) -> n
|
||||||
| `Join (_, a, _) -> a
|
| `Join (_, a, _) -> a
|
||||||
|
|
||||||
let join_ d (a : node) (b : node) =
|
let join_x = join `X
|
||||||
set_parent_on_children
|
let join_y = join `Y
|
||||||
{parent= a.parent; t= `Join (d, a, b); n= node_n ()}
|
let 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_x : node Lwd_utils.monoid = (empty_node (), join_x)
|
||||||
let pack_y : node Lwd_utils.monoid = (empty_node (), join_y)
|
let pack_y : node Lwd_utils.monoid = (empty_node (), join_y)
|
||||||
let pack_z : node Lwd_utils.monoid = (empty_node (), join_z)
|
let pack_z : node Lwd_utils.monoid = (empty_node (), join_z)
|
||||||
@ -1359,87 +1465,13 @@ module Panel = struct
|
|||||||
let ( ^*^ ) = join_z
|
let ( ^*^ ) = join_z
|
||||||
|
|
||||||
let append_ d (l : node -> node) (a : node) : node -> node =
|
let append_ d (l : node -> node) (a : node) : node -> node =
|
||||||
fun n -> l (join_ d a n)
|
fun n -> l (join d a n)
|
||||||
|
|
||||||
|
let empty_append = Fun.id
|
||||||
let append_x = append_ `X
|
let append_x = append_ `X
|
||||||
let append_y = append_ `Y
|
let append_y = append_ `Y
|
||||||
let append_z = append_ `Z
|
let append_z = append_ `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 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 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"
|
|
||||||
(record [field "n" (fun v -> v.n) int; any "..."])
|
|
||||||
v)
|
|
||||||
|
|
||||||
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 (fun ppf v -> pf ppf "%a" int v.n)) ] ) )
|
|
||||||
v
|
|
||||||
|
|
||||||
and pp_node ppf v = _pp_node pp_node_n ppf v
|
|
||||||
and pp_dump_node ppf v = _pp_node pp_dump_node ppf v
|
|
||||||
|
|
||||||
let pp_t = _pp_t pp_node_n
|
|
||||||
|
|
||||||
(* there's no difference between a node element and a node list what, tho an element is kinda like a node.t,
|
(* 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)
|
so i guess we'll use that to kinda emulate append (vs. concat which is what join is)
|
||||||
ugh maybe using types to build this double-linked binary-tree data structure is not a good idea.
|
ugh maybe using types to build this double-linked binary-tree data structure is not a good idea.
|
||||||
@ -1449,71 +1481,52 @@ module Panel = struct
|
|||||||
*)
|
*)
|
||||||
|
|
||||||
module Text = struct
|
module Text = struct
|
||||||
let rec of_string (str : string) : node =
|
let rec decode dec (l : 'a) :
|
||||||
let uudec = Uutf.decoder (`String str) in
|
'a * [< `Await | `End | `Uchar of Uchar.t] =
|
||||||
let rec dec (lx : node -> node) : 'a * (node -> node) =
|
match Uutf.decode dec with
|
||||||
match Uutf.decode uudec with
|
| `Malformed b ->
|
||||||
| `Malformed b ->
|
F.epr "Text.dec (Uutf.decode uudec)=`Malformed \"%s\"@."
|
||||||
dec (append_x lx (of_string (String.escaped b)))
|
(String.escaped b) ;
|
||||||
| (`Await | `Uchar _ | `End) as x -> (x, lx) in
|
decode dec (append_x l (of_string (String.escaped b)))
|
||||||
let uuline = Uuseg.create `Line_break in
|
| (`Await | `End | `Uchar _) as s -> (l, s)
|
||||||
let rec char (x, (l : node -> node)) =
|
|
||||||
match Uuseg.add uuline x with
|
|
||||||
| `End as x -> (l, x)
|
|
||||||
| `Await -> char (dec l)
|
|
||||||
| `Boundary as x when Uuseg.mandatory uuline -> (l, x)
|
|
||||||
| `Boundary ->
|
|
||||||
char (`Await, append_x l (node (`Atom (`Hint `Line))))
|
|
||||||
| `Uchar c ->
|
|
||||||
char (`Await, append_x l (node (`Atom (`Uchar c))))
|
|
||||||
in
|
|
||||||
let rec new_line la : node -> node =
|
|
||||||
match char (`Await, la) with
|
|
||||||
| l, `Boundary ->
|
|
||||||
new_line
|
|
||||||
(append_y la (l (node (`Atom (`Boundary `Line)))))
|
|
||||||
| l, `End -> l in
|
|
||||||
(new_line (fun n -> n)) (empty_node ())
|
|
||||||
|
|
||||||
(* let segment ?(boundary = `Word) ?(label = `Word) (node : node) :
|
and _of_string dec l =
|
||||||
node =
|
match decode dec l with
|
||||||
let uuseg = Uuseg.create boundary in
|
| l, `End -> l (atom (`Boundary `Text))
|
||||||
traverse_regions
|
| l, `Uchar c -> _of_string dec (append_x l (atom (`Uchar c)))
|
||||||
~node:(fun node -> node)
|
| l, _ -> _of_string dec l
|
||||||
~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 =
|
and of_string str =
|
||||||
segment ~boundary:`Word ~label:`Word node
|
_of_string
|
||||||
|
(Uutf.decoder
|
||||||
|
~nln:(`Readline (Uchar.of_int 0x000A))
|
||||||
|
(`String str) )
|
||||||
|
empty_append
|
||||||
|
|
||||||
let sentances node : node =
|
and _lines u d ly (lx, s) =
|
||||||
segment ~boundary:`Sentence ~label:`Sentance node
|
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 ->
|
||||||
|
_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 ->
|
||||||
|
_lines u d ly (append_x lx (atom (`Uchar c)), `Await)
|
||||||
|
|
||||||
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
|
end
|
||||||
|
|
||||||
let text = Text.of_string
|
let text = Text.lines
|
||||||
|
|
||||||
module Draw = struct
|
module Draw = struct
|
||||||
type d = [`X | `Y | `Z]
|
type d = [`X | `Y | `Z]
|
||||||
@ -1591,32 +1604,29 @@ module Panel = struct
|
|||||||
| `Hint _ -> empty_image
|
| `Hint _ -> empty_image
|
||||||
| `Empty -> empty_image
|
| `Empty -> empty_image
|
||||||
|
|
||||||
and attr ?(style = Style.empty) (attr, node) : image =
|
and attr ?(style = Style.empty) (a, n) : image =
|
||||||
match attr with
|
match a with
|
||||||
| `Style s -> pane ~style:(Style.merge s style) node
|
| `Style s -> node ~style:(Style.merge s style) n
|
||||||
| `Pad p -> pad p (pane ~style node)
|
| `Pad p -> pad p (node ~style n)
|
||||||
| `Shift s -> shift s (pane ~style node)
|
| `Shift s -> shift s (node ~style n)
|
||||||
| _ -> pane ~style node
|
| _ -> node ~style n
|
||||||
|
|
||||||
and join ?(style = Style.empty) (d, a, b) : image =
|
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 =
|
and node ?(style = Style.empty) (n : node) : image =
|
||||||
match node.t with
|
match n.t with
|
||||||
| `Atom a -> atom ~style a
|
| `Atom a -> atom ~style a
|
||||||
| `Attr a -> attr ~style a
|
| `Attr a -> attr ~style a
|
||||||
| `Join a -> join ~style a
|
| `Join a -> join ~style a
|
||||||
end
|
end
|
||||||
|
|
||||||
module Action = struct
|
module Action = struct
|
||||||
type segment_type =
|
type segment =
|
||||||
[`Char | `Word | `Phrase | `Line | `Page | `Region]
|
[ `Beginning of boundary
|
||||||
|
| `Forward of boundary
|
||||||
and segment =
|
| `Backward of boundary
|
||||||
[ `Beginning of segment_type
|
| `End of boundary ]
|
||||||
| `Forward of segment_type
|
|
||||||
| `Backward of segment_type
|
|
||||||
| `End of segment_type ]
|
|
||||||
|
|
||||||
and t =
|
and t =
|
||||||
[ `Move of segment
|
[ `Move of segment
|
||||||
@ -1655,23 +1665,12 @@ module Panel = struct
|
|||||||
| `Out -> "`Out" )
|
| `Out -> "`Out" )
|
||||||
ppf ()
|
ppf ()
|
||||||
|
|
||||||
let pp_segment_type ppf v =
|
|
||||||
any
|
|
||||||
( match v with
|
|
||||||
| `Char -> "`Char"
|
|
||||||
| `Word -> "`Word"
|
|
||||||
| `Phrase -> "`Phrase"
|
|
||||||
| `Line -> "`Line"
|
|
||||||
| `Page -> "`Page"
|
|
||||||
| `Region -> "`Region" )
|
|
||||||
ppf ()
|
|
||||||
|
|
||||||
let pp_segment ppf v =
|
let pp_segment ppf v =
|
||||||
( match v with
|
( match v with
|
||||||
| `Beginning s -> any "`Beginning " ++ const pp_segment_type s
|
| `Beginning s -> any "`Beginning " ++ const pp_boundary s
|
||||||
| `Forward s -> any "`Forward " ++ const pp_segment_type s
|
| `Forward s -> any "`Forward " ++ const pp_boundary s
|
||||||
| `Backward s -> any "`Backward " ++ const pp_segment_type s
|
| `Backward s -> any "`Backward " ++ const pp_boundary s
|
||||||
| `End s -> any "`End " ++ const pp_segment_type s )
|
| `End s -> any "`End " ++ const pp_boundary s )
|
||||||
ppf ()
|
ppf ()
|
||||||
|
|
||||||
let pp_t ppf v =
|
let pp_t ppf v =
|
||||||
@ -1718,57 +1717,104 @@ module Panel = struct
|
|||||||
| Some {t= `Join _; _} -> assert false
|
| Some {t= `Join _; _} -> assert false
|
||||||
(* shouldn't happen *)
|
(* shouldn't happen *)
|
||||||
|
|
||||||
let rec search_forward (n : node) (f : node -> 'a option) :
|
let rec tree_iter f n i =
|
||||||
'a option =
|
if i <> 0 then tree_iter f (f n) (i - 1) else f n
|
||||||
match f n with
|
|
||||||
| None -> (
|
|
||||||
match tree_next n with
|
|
||||||
| Some n' -> search_forward n' f
|
|
||||||
| None -> None )
|
|
||||||
| x -> x
|
|
||||||
|
|
||||||
let rec search_backward (n : node) (f : node -> 'a option) :
|
let rec search_ next f n =
|
||||||
'a option =
|
F.epr "search_ " ;
|
||||||
match tree_prev n with
|
match next n with
|
||||||
| None -> None
|
| Some n' -> (
|
||||||
| Some p -> (
|
F.epr "%a@." pp_n n' ;
|
||||||
match f p with
|
match f n' with
|
||||||
| None -> search_backward p f
|
| Some a -> (n', Some a)
|
||||||
| Some x -> Some x )
|
| 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 perform_action (a : Action.t) (c : cursor) : node option =
|
||||||
let r =
|
let mb ?(f = fun a -> a) b n =
|
||||||
match a with
|
match (b, n.t) with
|
||||||
| `Move (`Beginning `Char) -> None
|
| `Char, `Atom (`Uchar _)
|
||||||
| `Move (`Beginning `Word) ->
|
|`Word, `Atom (`Boundary `Word)
|
||||||
search_backward c.sel (fun n ->
|
|`Phrase, `Atom (`Boundary `Phrase)
|
||||||
match n.t with
|
|`Line, `Atom (`Boundary `Line)
|
||||||
| `Atom (`Boundary `Word) -> Some n
|
|`Page, `Atom (`Boundary `Page) ->
|
||||||
|
Some (f n)
|
||||||
|
| _ -> None in
|
||||||
|
match a with
|
||||||
|
| `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 )
|
| _ -> None )
|
||||||
| `Move (`Forward `Char) ->
|
c.sel
|
||||||
search_forward c.sel (fun n ->
|
with
|
||||||
match n.t with
|
| Some n' ->
|
||||||
| _ when n == c.sel -> None
|
Some
|
||||||
(* TODO proper detection of root | _ when n == c.root -> Some n *)
|
(tree_iter
|
||||||
| `Atom (`Uchar _) -> Some n
|
(fun nn ->
|
||||||
| _ -> None )
|
Option.value
|
||||||
| `Move (`Backward `Char) ->
|
(search_forward (mb `Char) nn)
|
||||||
search_backward c.sel (fun n ->
|
~default:nn )
|
||||||
match n.t with
|
(fst (search_ tree_prev (mb `Line) n'))
|
||||||
(* TODO proper detection of root | _ when n == c.root -> Some np *)
|
!i )
|
||||||
| `Atom (`Uchar _) -> Some n
|
| None -> None )
|
||||||
| _ -> None )
|
| `Move (`Forward b) ->
|
||||||
| `Move _ -> None
|
search_forward (mb ~f:tree_uchar_back b) c.sel
|
||||||
| `Yank _s -> None
|
| `Move (`Backward b) ->
|
||||||
| `Kill _s -> None
|
search_backward (mb ~f:tree_uchar_fwd b) c.sel
|
||||||
| `Descend -> Some (sub c.sel)
|
| `Move (`Beginning b) ->
|
||||||
| `Ascend -> c.sel.parent
|
(* uses last searched node regardless of match *)
|
||||||
| `Custom _s -> None in
|
Some (tree_uchar_fwd (fst (search_ tree_prev (mb b) c.sel)))
|
||||||
match r with
|
| `Move (`End b) ->
|
||||||
| Some n ->
|
(* uses last searched node regardless of match *)
|
||||||
c.sel <- n ;
|
Some
|
||||||
Some n
|
(tree_uchar_back (fst (search_ tree_next (mb b) c.sel)))
|
||||||
| None -> None
|
| `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]
|
type event_status = [`Handled | `Event of Event.t]
|
||||||
|
|
||||||
@ -1798,61 +1844,48 @@ module Panel = struct
|
|||||||
[([Ctrl], C 'x'); ([], U `Backspace)]
|
[([Ctrl], C 'x'); ([], U `Backspace)]
|
||||||
[`Kill (`Backward `Phrase)]
|
[`Kill (`Backward `Phrase)]
|
||||||
|> add [([Ctrl], C 'q')] [`Ascend]
|
|> add [([Ctrl], C 'q')] [`Ascend]
|
||||||
|> add [([Ctrl], C 'e')] [`Descend]
|
|> add [([Ctrl], C 'z')] [`Descend]
|
||||||
|
|
||||||
let join_search_forward n =
|
|
||||||
search_forward n (fun v ->
|
|
||||||
match v.t with `Join _ -> Some v | _ -> None )
|
|
||||||
|
|
||||||
let cursor_attr = `Style Style.(bg Color.(v 1. 1. 0. 1.))
|
let cursor_attr = `Style Style.(bg Color.(v 1. 1. 0. 1.))
|
||||||
|
|
||||||
let textedit_handler ?(bindings = textedit_bindings) (n : node) =
|
let textedit_handler ?(bindings = textedit_bindings) (n : node) =
|
||||||
let bind = Key.Bind.init bindings in
|
|
||||||
let c =
|
|
||||||
{ root= n
|
|
||||||
; sel=
|
|
||||||
insert_attr cursor_attr
|
|
||||||
( match join_search_forward n with
|
|
||||||
| Some n -> n
|
|
||||||
| None -> n ) } in
|
|
||||||
Format.pp_set_max_boxes F.stderr 64 ;
|
Format.pp_set_max_boxes F.stderr 64 ;
|
||||||
Format.pp_set_margin F.stderr 120 ;
|
(*full screen fynn *)
|
||||||
Format.(
|
Format.pp_safe_set_geometry F.stderr ~max_indent:150 ~margin:230 ;
|
||||||
F.epr
|
let bind = Key.Bind.init bindings in
|
||||||
"@[<hv>F.stderr margin: %d, max_indent: %d, max_boxes: %d \
|
let sel = insert_attr cursor_attr n in
|
||||||
@]@."
|
let c =
|
||||||
(pp_get_margin F.stderr ())
|
{root= attr (`Handler (fun _ _ -> Lwt.return_none)) sel; sel}
|
||||||
(pp_get_max_indent F.stderr ())
|
in
|
||||||
(pp_get_max_boxes F.stderr ())) ;
|
c.root.t <-
|
||||||
node
|
`Attr
|
||||||
(`Attr
|
|
||||||
( `Handler
|
( `Handler
|
||||||
(fun (_ : node) (e : Event.t) : Event.t option Lwt.t ->
|
(fun (_ : node) (e : Event.t) : Event.t option Lwt.t ->
|
||||||
match Key.Bind.resolve_events bind [e] with
|
match Key.Bind.resolve_events bind [e] with
|
||||||
| x :: _ ->
|
| x :: _ ->
|
||||||
c.sel <- remove_attr c.sel ;
|
c.sel <- remove_attr c.sel ;
|
||||||
F.epr
|
(*F.epr
|
||||||
"textedit_handler c.root=@.@[%a@]@.c.sel=%a@."
|
"textedit_handler c.sel.n=%d@ c.root=@ @[%a@]@."
|
||||||
pp_dump_node c.root pp_node c.sel ;
|
pp_node_n c.sel pp_node_structure c.root ; *)
|
||||||
( match perform_action x c with
|
( match perform_action x c with
|
||||||
| Some _ ->
|
| Some n' ->
|
||||||
F.epr
|
F.epr "textedit action @[%a@] Success@."
|
||||||
"textedit_handler perform_action @[%a@] \
|
Action.pp_t x ;
|
||||||
success@."
|
c.sel <- n'
|
||||||
Action.pp_t x
|
|
||||||
| None ->
|
| None ->
|
||||||
F.epr
|
F.epr "textedit action @[%a@] Failure@."
|
||||||
"textedit_handler perform_action @[%a@] \
|
|
||||||
FAILURE@."
|
|
||||||
Action.pp_t x ) ;
|
Action.pp_t x ) ;
|
||||||
c.sel <- insert_attr cursor_attr c.sel ;
|
c.sel <- insert_attr cursor_attr c.sel ;
|
||||||
Lwt.return_none
|
Lwt.return_none
|
||||||
| [] -> Lwt.return_some e )
|
| [] -> Lwt.return_some e )
|
||||||
, n ) )
|
, n ) ;
|
||||||
|
set_parent_on_children c.root
|
||||||
|
|
||||||
let handler_of_node (n : node) : handler option =
|
let handler_of_node (n : node) : handler option =
|
||||||
search_forward n (fun n ->
|
let f n =
|
||||||
match n.t with `Attr (`Handler f, _) -> Some f | _ -> None )
|
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 =
|
let handle_event (n : node) (ev : Event.t) : event_status Lwt.t =
|
||||||
match handler_of_node n with
|
match handler_of_node n with
|
||||||
@ -1881,7 +1914,7 @@ module Panel = struct
|
|||||||
() ) ;
|
() ) ;
|
||||||
Lwt.return_unit )
|
Lwt.return_unit )
|
||||||
ev
|
ev
|
||||||
>|= fun () -> Draw.pane r )
|
>|= fun () -> Draw.node r )
|
||||||
|
|
||||||
let test =
|
let test =
|
||||||
panel
|
panel
|
||||||
@ -1889,13 +1922,14 @@ module Panel = struct
|
|||||||
(textedit_handler
|
(textedit_handler
|
||||||
(style Style.dark
|
(style Style.dark
|
||||||
(join_y
|
(join_y
|
||||||
(* (join_y
|
(join_y
|
||||||
(Text.of_string
|
(Text.of_string
|
||||||
"-- welcome to my land of idiocy ---" )
|
"-- welcome to my land of idiocy ---" )
|
||||||
(join_x *)
|
( ( Text.of_string "hello bitch"
|
||||||
(Text.of_string "hello bitch")
|
^^ Text.of_string "!\n sup daddy" )
|
||||||
(*
|
^/^ (text "hello bitch" ^^ text "!\n sup daddy")
|
||||||
(Text.of_string "!\n sup daddy") ) ) *)
|
^/^ text "hello bitch" ^/^ text "!\n sup daddy"
|
||||||
|
) )
|
||||||
(Text.of_string "123") ) ) ) )
|
(Text.of_string "123") ) ) ) )
|
||||||
end
|
end
|
||||||
end
|
end
|
||||||
|
|||||||
Reference in New Issue
Block a user