1 Commits

205
human.ml
View File

@ -1383,10 +1383,13 @@ module Panel = struct
braces
(record ~sep:semi [field "n" Fun.id pp_node_n; any "..."]))
and pp_node ppf = _pp_node pp_node_n_record ppf
and pp_node ppf = _pp_node pp_node_n ppf
and pp_dump_node ppf = _pp_node pp_dump_node ppf
let pp_t = _pp_t pp_node_n_record
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.(
@ -1601,18 +1604,18 @@ 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)
| _ -> 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
@ -1714,57 +1717,104 @@ module Panel = struct
| Some {t= `Join _; _} -> assert false
(* shouldn't happen *)
let rec search_forward (n : node) (f : node -> 'a option) :
'a option =
match f n with
| None -> (
match tree_next n with
| Some n' -> search_forward n' f
| None -> None )
| x -> x
let rec tree_iter f n i =
if i <> 0 then tree_iter f (f n) (i - 1) else f n
let rec search_backward (n : node) (f : node -> 'a option) :
'a option =
match tree_prev n with
| None -> None
| Some p -> (
match f p with
| None -> search_backward p f
| Some x -> Some x )
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 r =
match a with
| `Move (`Beginning `Char) -> None
| `Move (`Beginning `Word) ->
search_backward c.sel (fun n ->
match n.t with
| `Atom (`Boundary `Word) -> Some n
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 (`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 )
| `Move (`Forward `Char) ->
search_forward c.sel (fun n ->
match n.t with
| _ when n == c.sel -> None
(* TODO proper detection of root | _ when n == c.root -> Some n *)
| `Atom (`Uchar _) -> Some n
| _ -> None )
| `Move (`Backward `Char) ->
search_backward c.sel (fun n ->
match n.t with
(* TODO proper detection of root | _ when n == c.root -> Some np *)
| `Atom (`Uchar _) -> Some n
| _ -> None )
| `Move _ -> None
| `Yank _s -> None
| `Kill _s -> None
| `Descend -> Some (sub c.sel)
| `Ascend -> c.sel.parent
| `Custom _s -> None in
match r with
| Some n ->
c.sel <- n ;
Some n
| 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]
@ -1794,28 +1844,21 @@ module Panel = struct
[([Ctrl], C 'x'); ([], U `Backspace)]
[`Kill (`Backward `Phrase)]
|> add [([Ctrl], C 'q')] [`Ascend]
|> add [([Ctrl], C 'e')] [`Descend]
let join_search_forward n =
search_forward n (fun v ->
match v.t with `Join _ -> Some v | _ -> None )
|> 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) =
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 ;
(*full screen fynn *)
Format.pp_safe_set_geometry F.stderr ~max_indent:150 ~margin:230 ;
node
(`Attr
let bind = Key.Bind.init bindings in
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
@ -1825,20 +1868,24 @@ module Panel = struct
"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 _ ->
| Some n' ->
F.epr "textedit action @[%a@] Success@."
Action.pp_t x
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
@ -1867,7 +1914,7 @@ module Panel = struct
() ) ;
Lwt.return_unit )
ev
>|= fun () -> Draw.pane r )
>|= fun () -> Draw.node r )
let test =
panel