basic text field edition
This commit is contained in:
cqc
40
boot_js.ml
40
boot_js.ml
@ -94,24 +94,28 @@ let _ =
|
||||
let ui =
|
||||
Nottui_widgets.(
|
||||
let string s = Lwd.pure @@ Nottui_widgets.string s in
|
||||
scroll_area
|
||||
@@ Lwd_utils.pack Ui.pack_y
|
||||
[
|
||||
edit_field edit_me;
|
||||
string "derp derp derp";
|
||||
string "herp herp derp";
|
||||
string "ding dong beep beep";
|
||||
string "derp derp derp";
|
||||
string "herp herp derp";
|
||||
string "ding dong beep beep";
|
||||
string "derp derp derp";
|
||||
string "herp herp derp";
|
||||
string "ding dong beep beep";
|
||||
string "derp derp derp";
|
||||
string "herp herp derp";
|
||||
string "ding dong beep beep";
|
||||
main_menu_item wm "Quit" (fun () -> exit 0);
|
||||
])
|
||||
line_table_of_string
|
||||
"edit me?\n\
|
||||
derp derp derp\n\
|
||||
herp herp derp\n\
|
||||
ding dong beep beep"
|
||||
(* @@ Lwd_utils.pack Ui.pack_y
|
||||
[
|
||||
edit_field edit_me;
|
||||
string "derp derp derp";
|
||||
string "herp herp derp";
|
||||
string "ding dong beep beep";
|
||||
string "derp derp derp";
|
||||
string "herp herp derp";
|
||||
string "ding dong beep beep";
|
||||
string "derp derp derp";
|
||||
string "herp herp derp";
|
||||
string "ding dong beep beep";
|
||||
string "derp derp derp";
|
||||
string "herp herp derp";
|
||||
string "ding dong beep beep";
|
||||
main_menu_item wm "Quit" (fun () -> exit 0);
|
||||
] *))
|
||||
in
|
||||
let root =
|
||||
Lwd.set body
|
||||
|
||||
601
human.ml
601
human.ml
@ -256,8 +256,7 @@ module Git_console_http = struct
|
||||
| Ok (_resp, contents) ->
|
||||
Lwt.return_ok (`Data (Cstruct.of_string contents))
|
||||
| Error err ->
|
||||
Lwt.return_error
|
||||
(`Msg (Fmt.str "%a" Git_af.pp_error err)))
|
||||
Lwt.return_error (`Msg (Fmt.str "%a" pp_error err)))
|
||||
|
||||
let close _ = Lwt.return_unit
|
||||
|
||||
@ -489,14 +488,6 @@ module Input = struct
|
||||
type code =
|
||||
[ `Uchar of Uchar.t (* A unicode character. *) | special ]
|
||||
|
||||
type mods = [ `Super | `Meta | `Ctrl | `Shift ] list
|
||||
|
||||
type mouse =
|
||||
[ `Press of button | `Drag | `Release ] * (float * float) * mods
|
||||
|
||||
type paste = [ `Start | `End ]
|
||||
type keyaction = [ `Press | `Release | `Repeat ]
|
||||
|
||||
(* stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *)
|
||||
let string_of_code = function
|
||||
| `Uchar ch ->
|
||||
@ -518,6 +509,25 @@ module Input = struct
|
||||
| `Delete -> "Delete"
|
||||
| `Backspace -> "Backspace"
|
||||
| `Unknown s -> String.concat "Unknown " [ "\""; s; "\"" ]
|
||||
| _ -> "Code Unknown!"
|
||||
|
||||
let pp_code ppf v = F.pf ppf "%s" (string_of_code v)
|
||||
|
||||
type mods = [ `Super | `Meta | `Ctrl | `Shift ] list
|
||||
|
||||
let pp_mods =
|
||||
F.(
|
||||
list (fun ppf -> function
|
||||
| `Super -> pf ppf "`Super"
|
||||
| `Meta -> pf ppf "`Meta"
|
||||
| `Ctrl -> pf ppf "`Ctrl"
|
||||
| `Shift -> pf ppf "`Shift"))
|
||||
|
||||
type mouse =
|
||||
[ `Press of button | `Drag | `Release ] * (float * float) * mods
|
||||
|
||||
type paste = [ `Start | `End ]
|
||||
type keyaction = [ `Press | `Release | `Repeat ]
|
||||
end
|
||||
|
||||
module Event_js = struct
|
||||
@ -583,14 +593,17 @@ module NVG = struct
|
||||
and lightcyan = rgbf ~r:0.5 ~g:1.0 ~b:1.0
|
||||
and lightwhite = rgbf ~r:1.0 ~g:1.0 ~b:1.0
|
||||
|
||||
let ( = ) a b = a.r = b.r && a.g = b.g && a.b = b.b && a.a = b.a
|
||||
|
||||
let ( ++ ) a b =
|
||||
(* {
|
||||
r = Float.clamp ~min:0. ~max:1. (a.r +. b.r);
|
||||
g = Float.clamp ~min:0. ~max:1. (a.g +. b.g);
|
||||
b = Float.clamp ~min:0. ~max:1. (a.b +. b.b);
|
||||
a = Float.clamp ~min:0. ~max:1. (a.a +. b.a);
|
||||
} *)
|
||||
if a = none then b else a
|
||||
{
|
||||
r = Float.clamp ~min:0. ~max:1. (a.r +. b.r);
|
||||
g = Float.clamp ~min:0. ~max:1. (a.g +. b.g);
|
||||
b = Float.clamp ~min:0. ~max:1. (a.b +. b.b);
|
||||
a = Float.clamp ~min:0. ~max:1. (a.a +. b.a);
|
||||
}
|
||||
|
||||
let replace ~prev ~next = if next = none then prev else next
|
||||
|
||||
let pp ppf t : unit =
|
||||
if t != none then
|
||||
@ -746,6 +759,8 @@ module Style = struct
|
||||
match t.font with
|
||||
| `Sans -> Text.set_font_face vg ~name:"sans"
|
||||
| _ -> ()
|
||||
|
||||
let replace ~prev ~next = merge prev next
|
||||
end
|
||||
|
||||
type t = { fg : Color.t; bg : Color.t; font : Font.t }
|
||||
@ -772,6 +787,13 @@ module Style = struct
|
||||
font = Font.merge a1.font a2.font;
|
||||
}
|
||||
|
||||
let replace ~prev ~next =
|
||||
{
|
||||
fg = Color.replace ~prev:prev.fg ~next:next.fg;
|
||||
bg = Color.replace ~prev:prev.bg ~next:next.bg;
|
||||
font = Font.replace ~prev:prev.font ~next:next.font;
|
||||
}
|
||||
|
||||
let fg ?(t = empty) c = { t with fg = c }
|
||||
let bg ?(t = empty) c = { t with bg = c }
|
||||
let font ?(t = empty) c = { t with font = c }
|
||||
@ -823,15 +845,19 @@ module I = struct
|
||||
V2.(v (Float.max (x p1) (x p2)) (Float.max (y p1) (y p2)))
|
||||
[@@inline]
|
||||
|
||||
let bounds_segment vg p : Text.t -> NVG.Text.bounds = function
|
||||
| String s ->
|
||||
let open NVG.Text in
|
||||
let { ascender; _ } = NVG.Text.metrics vg in
|
||||
bounds vg ~x:(V2.x p) ~y:(V2.y p +. ascender) s
|
||||
|
||||
let rec size vg p = function
|
||||
| Empty -> V2.zero
|
||||
| Segment s ->
|
||||
let NVG.Bounds.{ xmin; ymin; xmax; ymax } =
|
||||
(NVG.Text.bounds vg ~x:(V2.x p) ~y:(V2.y p)
|
||||
(Text.to_string s))
|
||||
.box
|
||||
let NVG.Text.{ box = { ymax; ymin; _ }; advance } =
|
||||
bounds_segment vg p s
|
||||
in
|
||||
V2.v (xmax -. xmin) (ymax -. ymin)
|
||||
V2.v advance (ymax -. ymin)
|
||||
| Attr (t, _a) -> size vg p t
|
||||
| Hcompose (t1, t2) ->
|
||||
let p1 = size vg p t1 in
|
||||
@ -853,7 +879,7 @@ module I = struct
|
||||
let void w h = Void (P2.v w h)
|
||||
|
||||
let attr a = function
|
||||
| Attr (t, a0) -> Attr (t, A.(a ++ a0))
|
||||
| Attr (t, a0) -> Attr (t, A.(replace ~prev:a0 ~next:a))
|
||||
| t -> Attr (t, a)
|
||||
|
||||
let ( <|> ) t1 t2 =
|
||||
@ -877,11 +903,11 @@ module I = struct
|
||||
(* crop is positive value, pad is negative *)
|
||||
|
||||
let hcrop left right img =
|
||||
Log.debug (fun m -> m "Hcrop (%f, %f)" left right);
|
||||
(* Log.debug (fun m -> m "Hcrop (%f, %f)" left right); *)
|
||||
Hcrop (img, left, right)
|
||||
|
||||
let vcrop top bottom img =
|
||||
Log.debug (fun m -> m "Vcrop (%f, %f)" top bottom);
|
||||
(* Log.debug (fun m -> m "Vcrop (%f, %f)" top bottom); *)
|
||||
Vcrop (img, top, bottom)
|
||||
|
||||
let crop ?(l = 0.) ?(r = 0.) ?(t = 0.) ?(b = 0.) img =
|
||||
@ -1042,7 +1068,7 @@ module I = struct
|
||||
set_fill_color vg ~color;
|
||||
fill vg;
|
||||
NVG.restore vg;
|
||||
Log.debug (fun m -> m "fill_box: %a" Box2.pp b);
|
||||
(* Log.debug (fun m -> m "fill_box: %a" Box2.pp b); *)
|
||||
Box2.size b
|
||||
|
||||
let path_box vg color ?(width = 0.) b =
|
||||
@ -1073,8 +1099,9 @@ module I = struct
|
||||
| Segment v -> fmt "@[<h>Segment %a@]" ppf Text.pp v
|
||||
| Attr (t, a) ->
|
||||
fmt "@[<h>Attr %a@]" ppf
|
||||
(pair ~sep:comma A.pp (pp ~attr:A.(attr ++ a)))
|
||||
(A.(attr ++ a), t)
|
||||
(pair ~sep:comma A.pp
|
||||
(pp ~attr:A.(replace ~prev:attr ~next:a)))
|
||||
(A.(replace ~prev:attr ~next:a), t)
|
||||
| Hcompose a -> fmt "Hcat %a" ppf compose a
|
||||
| Vcompose a -> fmt "Vcat %a" ppf compose a
|
||||
| Zcompose a -> fmt "Zcat %a" ppf compose a
|
||||
@ -1084,18 +1111,37 @@ module I = struct
|
||||
fmt "Vcrop (%.1f,%.1f,%a)" ppf top bottom (pp ~attr) t
|
||||
| Void dim -> fmt "Void %a" ppf (parens V2.pp) dim
|
||||
|
||||
let segment_kern_cache = ref (Box2.zero, "")
|
||||
|
||||
let rec segment vg p : Text.t -> P2.t = function
|
||||
| String s ->
|
||||
(* Log.debug (fun m -> m "I.Draw.segment p=%a %s" Gg.V2.pp p s); *)
|
||||
(* let p' =
|
||||
let cache_p, cache_s = !segment_kern_cache in
|
||||
(* tries to get the kerning right across segments *)
|
||||
if V2.(equal (Box2.max cache_p) p) then
|
||||
V2.(
|
||||
Box2.o cache_p
|
||||
+ v
|
||||
((bounds_segment vg (Box2.o cache_p)
|
||||
(Text.of_string (cache_s ^ s)))
|
||||
.advance
|
||||
-. (bounds_segment vg p (Text.of_string s)).advance
|
||||
)
|
||||
0.)
|
||||
else p
|
||||
in *)
|
||||
let metrics = NVG.Text.metrics vg in
|
||||
NVG.Text.text vg ~x:(V2.x p)
|
||||
~y:(V2.y p +. metrics.ascender)
|
||||
(* TODO make segments include neighbors so kerning is correct *)
|
||||
s;
|
||||
let NVG.Bounds.{ xmin; ymin; xmax; ymax } =
|
||||
(NVG.Text.bounds vg ~x:(V2.x p) ~y:(V2.y p) s).box
|
||||
|
||||
let sz =
|
||||
V2.v (bounds_segment vg p (Text.of_string s)).advance
|
||||
metrics.line_height
|
||||
in
|
||||
V2.v (xmax -. xmin) (ymax -. ymin)
|
||||
segment_kern_cache := (Box2.(v p sz), s);
|
||||
sz
|
||||
|
||||
and node vg attr p n : p2 =
|
||||
(* returns the *size* of the drawn area not the max coordinates anymore *)
|
||||
@ -1104,12 +1150,12 @@ module I = struct
|
||||
| Empty | Void _ -> p
|
||||
| Segment text -> segment vg p text
|
||||
| Attr (i, a) ->
|
||||
let a0 = A.(attr ++ a) in
|
||||
let a0 = A.(replace ~prev:attr ~next:a) in
|
||||
if
|
||||
A.(a0.bg) != NVG.Color.transparent
|
||||
&& A.(a0.bg) != A.(attr.bg)
|
||||
(A.(a.bg) != A.(attr.bg))
|
||||
&& A.(a0.bg) != NVG.Color.transparent
|
||||
then fill_box vg a0.bg (Box2.v p (size vg p i)) |> ignore;
|
||||
if A.(attr.fg) != a0.fg then (
|
||||
if A.(attr.fg) != a.fg then (
|
||||
NVG.set_fill_color vg ~color:Style.(a0.fg);
|
||||
NVG.set_stroke_color vg ~color:Style.(a0.fg));
|
||||
node vg a0 p i
|
||||
@ -1287,6 +1333,10 @@ module Nottui = struct
|
||||
module Ui = struct
|
||||
type may_handle = [ `Unhandled | `Handled ]
|
||||
|
||||
let pp_may_handle ppf = function
|
||||
| `Unhandled -> F.pf ppf "`Unhandled"
|
||||
| `Handled -> F.pf ppf "`Unhandled"
|
||||
|
||||
type mouse_handler =
|
||||
x:float ->
|
||||
y:float ->
|
||||
@ -1309,6 +1359,25 @@ module Nottui = struct
|
||||
[ Input.special | `Uchar of Uchar.t | semantic_key ]
|
||||
* Input.mods
|
||||
|
||||
let pp_key =
|
||||
F.(
|
||||
pair
|
||||
(fun ppf v ->
|
||||
match v with
|
||||
| `Copy -> pf ppf "`Copy"
|
||||
| `Paste -> pf ppf "`Paste"
|
||||
| `Focus v ->
|
||||
pf ppf "`Focus %s"
|
||||
(match v with
|
||||
| `Next -> "`Next"
|
||||
| `Prev -> "`Prev"
|
||||
| `Left -> "`Left"
|
||||
| `Right -> "`Right"
|
||||
| `Up -> "`Up"
|
||||
| `Down -> "`Down")
|
||||
| a -> pf ppf "%a" Input.pp_code a)
|
||||
Input.pp_mods)
|
||||
|
||||
type mouse = Input.mouse
|
||||
|
||||
type event =
|
||||
@ -1627,11 +1696,11 @@ module Nottui = struct
|
||||
(a +. ratio, b +. flex -. ratio)
|
||||
else (a, b)
|
||||
in
|
||||
Log.debug (fun m ->
|
||||
m
|
||||
"split: a=%.1f sa=%.1f b=%.1f sb=%.1f total=%.1f (%.1f, \
|
||||
%.1f)"
|
||||
a sa b sb total a' b');
|
||||
(* Log.debug (fun m ->
|
||||
m
|
||||
"split: a=%.1f sa=%.1f b=%.1f sb=%.1f total=%.1f (%.1f, \
|
||||
%.1f)"
|
||||
a sa b sb total a' b'); *)
|
||||
(a', b')
|
||||
|
||||
let pack ~fixed ~stretch total g1 g2 =
|
||||
@ -1645,9 +1714,9 @@ module Nottui = struct
|
||||
| `Neutral -> (flex /. 2., fixed)
|
||||
| `Positive -> (flex, fixed)
|
||||
in
|
||||
Log.debug (fun m ->
|
||||
m "pack fixed=%.1f stretch=%.1f total=%.1f (%.1f, %.1f)"
|
||||
fixed stretch total v1 v2);
|
||||
(* Log.debug (fun m ->
|
||||
m "pack fixed=%.1f stretch=%.1f total=%.1f (%.1f, %.1f)"
|
||||
fixed stretch total v1 v2); *)
|
||||
(v1, v2)
|
||||
|
||||
let has_transient_sensor flags =
|
||||
@ -1794,16 +1863,7 @@ module Nottui = struct
|
||||
| Y (a, b) -> (max a.w b.w, a.h +. b.h)
|
||||
| Z (a, b) -> (max a.w b.w, max a.h b.h)
|
||||
in
|
||||
{
|
||||
ui with
|
||||
w;
|
||||
h;
|
||||
sw = w;
|
||||
sh = h;
|
||||
desc;
|
||||
sensor_cache = None;
|
||||
cache;
|
||||
}
|
||||
{ ui with w; h; desc; sensor_cache = None; cache }
|
||||
|
||||
let update t size (ui : Ui.t) =
|
||||
t.size <- size;
|
||||
@ -1876,8 +1936,8 @@ module Nottui = struct
|
||||
|
||||
let resize_canvas vg rw rh image =
|
||||
let w, h = V2.to_tuple @@ I.size vg V2.zero image in
|
||||
Log.debug (fun m ->
|
||||
m "resize_canvas: w=%.1f rw=%.1f h=%.1f rh=%.1f" w rw h rh);
|
||||
(* Log.debug (fun m ->
|
||||
m "resize_canvas: w=%.1f rw=%.1f h=%.1f rh=%.1f" w rw h rh); *)
|
||||
if w <> rw || h <> rh then I.pad ~r:(rw -. w) ~b:(rh -. h) image
|
||||
else image
|
||||
|
||||
@ -1907,109 +1967,13 @@ module Nottui = struct
|
||||
then `Handled
|
||||
else `Unhandled
|
||||
|
||||
let rec _render_node vg (vx1 : size1) (vy1 : size1) (vx2 : size1)
|
||||
let rec render_node vg (vx1 : size1) (vy1 : size1) (vx2 : size1)
|
||||
(vy2 : size1) (sw : size1) (sh : size1) (t : ui) : cache =
|
||||
match t.desc with
|
||||
| Atom image ->
|
||||
{
|
||||
vx = Interval.make 0. sw;
|
||||
vy = Interval.make 0. sh;
|
||||
image = resize_canvas vg sw sh image;
|
||||
}
|
||||
| Size_sensor (desc, handler) ->
|
||||
handler ~w:sw ~h:sh;
|
||||
render_node vg vx1 vy1 vx2 vy2 sw sh desc
|
||||
| Transient_sensor (desc, _) | Permanent_sensor (desc, _) ->
|
||||
render_node vg vx1 vy1 vx2 vy2 sw sh desc
|
||||
| Focus_area (desc, _) | Mouse_handler (desc, _) ->
|
||||
render_node vg vx1 vy1 vx2 vy2 sw sh desc
|
||||
| Shift_area (t', sx, sy) ->
|
||||
let cache =
|
||||
render_node vg (vx1 +. sx) (vy1 +. sy) (vx2 +. sx)
|
||||
(vy2 +. sy) (sx +. sw) (sy +. sh) t'
|
||||
in
|
||||
let vx = Interval.make vx1 vx2
|
||||
and vy = Interval.make vy1 vy2 in
|
||||
let image =
|
||||
resize_canvas vg sw sh (I.crop ~l:sx ~t:sy cache.image)
|
||||
in
|
||||
{ vx; vy; image }
|
||||
| X (a, b) ->
|
||||
let aw, bw = split ~a:a.w ~sa:a.sw ~b:b.w ~sb:b.sw sw in
|
||||
let ca = render_node vg vx1 vy1 vx2 vy2 aw sh a in
|
||||
let cb =
|
||||
render_node vg (vx1 -. aw) vy1 (vx2 -. aw) vy2 bw sh b
|
||||
in
|
||||
let vx =
|
||||
Interval.make
|
||||
(max (Interval.fst ca.vx) (Interval.fst cb.vx +. aw))
|
||||
(min (Interval.snd ca.vx) (Interval.snd cb.vx +. aw))
|
||||
and vy =
|
||||
Interval.make
|
||||
(max (Interval.fst ca.vy) (Interval.fst cb.vy))
|
||||
(min (Interval.snd ca.vy) (Interval.snd cb.vy))
|
||||
and image =
|
||||
resize_canvas vg sw sh I.(ca.image <|> cb.image)
|
||||
in
|
||||
{ vx; vy; image }
|
||||
| Y (a, b) ->
|
||||
let ah, bh = split ~a:a.h ~sa:a.sh ~b:b.h ~sb:b.sh sh in
|
||||
let ca = render_node vg vx1 vy1 vx2 vy2 sw ah a in
|
||||
let cb =
|
||||
render_node vg vx1 (vy1 -. ah) vx2 (vy2 -. ah) sw bh b
|
||||
in
|
||||
let vx =
|
||||
Interval.make
|
||||
(max (Interval.fst ca.vx) (Interval.fst cb.vx))
|
||||
(min (Interval.snd ca.vx) (Interval.snd cb.vx))
|
||||
and vy =
|
||||
Interval.make
|
||||
(max (Interval.fst ca.vy) (Interval.fst cb.vy +. ah))
|
||||
(min (Interval.snd ca.vy) (Interval.snd cb.vy +. ah))
|
||||
and image =
|
||||
resize_canvas vg sw sh (I.( <-> ) ca.image cb.image)
|
||||
in
|
||||
{ vx; vy; image }
|
||||
| Z (a, b) ->
|
||||
let ca = render_node vg vx1 vy1 vx2 vy2 sw sh a in
|
||||
let cb = render_node vg vx1 vy1 vx2 vy2 sw sh b in
|
||||
let vx =
|
||||
Interval.make
|
||||
(max (Interval.fst ca.vx) (Interval.fst cb.vx))
|
||||
(min (Interval.snd ca.vx) (Interval.snd cb.vx))
|
||||
and vy =
|
||||
Interval.make
|
||||
(max (Interval.fst ca.vy) (Interval.fst cb.vy))
|
||||
(min (Interval.snd ca.vy) (Interval.snd cb.vy))
|
||||
and image =
|
||||
resize_canvas vg sw sh (I.( </> ) cb.image ca.image)
|
||||
in
|
||||
{ vx; vy; image }
|
||||
| Resize (t, _, _, g) ->
|
||||
let open Gravity in
|
||||
let dx, rw =
|
||||
pack ~fixed:t.w ~stretch:t.sw sw (h (p1 g)) (h (p2 g))
|
||||
in
|
||||
let dy, rh =
|
||||
pack ~fixed:t.h ~stretch:t.sh sh (v (p1 g)) (v (p2 g))
|
||||
in
|
||||
let c =
|
||||
render_node vg (vx1 -. dx) (vy1 -. dy) (vx2 -. dx)
|
||||
(vy2 -. dy) rw rh t
|
||||
in
|
||||
let image = resize_canvas2 vg dx dy sw sh c.image in
|
||||
let vx = Interval.shift c.vx dx in
|
||||
let vy = Interval.shift c.vy dy in
|
||||
{ vx; vy; image }
|
||||
| Event_filter (t, _f) -> render_node vg vx1 vy1 vx2 vy2 sw sh t
|
||||
|
||||
and render_node vg (vx1 : size1) (vy1 : size1) (vx2 : size1)
|
||||
(vy2 : size1) (sw : size1) (sh : size1) (t : ui) : cache =
|
||||
Log.debug (fun m ->
|
||||
m
|
||||
"render_node vx1=%.0f@ vy1=%.0f@ vx2=%.0f@ vy2=%.0f@ \
|
||||
sw=%.0f@ sh=%.0f@ @[%a@]"
|
||||
vx1 vy1 vx2 vy2 sw sh pp t);
|
||||
(* Log.debug (fun m ->
|
||||
m
|
||||
"render_node vx1=%.0f@ vy1=%.0f@ vx2=%.0f@ vy2=%.0f@ \
|
||||
sw=%.0f@ sh=%.0f@ @[%a@]"
|
||||
vx1 vy1 vx2 vy2 sw sh pp t); *)
|
||||
if
|
||||
let cache = t.cache in
|
||||
vx1 >= Interval.fst cache.vx
|
||||
@ -2024,7 +1988,107 @@ module Nottui = struct
|
||||
image = I.void sw sh;
|
||||
}
|
||||
else
|
||||
let cache = _render_node vg vx1 vy1 vx2 vy2 sw sh t in
|
||||
let cache =
|
||||
match t.desc with
|
||||
| Atom image ->
|
||||
{
|
||||
vx = Interval.make 0. sw;
|
||||
vy = Interval.make 0. sh;
|
||||
image = resize_canvas vg sw sh image;
|
||||
}
|
||||
| Size_sensor (desc, handler) ->
|
||||
handler ~w:sw ~h:sh;
|
||||
render_node vg vx1 vy1 vx2 vy2 sw sh desc
|
||||
| Transient_sensor (desc, _) | Permanent_sensor (desc, _) ->
|
||||
render_node vg vx1 vy1 vx2 vy2 sw sh desc
|
||||
| Focus_area (desc, _) | Mouse_handler (desc, _) ->
|
||||
render_node vg vx1 vy1 vx2 vy2 sw sh desc
|
||||
| Shift_area (t', sx, sy) ->
|
||||
let cache =
|
||||
render_node vg (vx1 +. sx) (vy1 +. sy) (vx2 +. sx)
|
||||
(vy2 +. sy) (sx +. sw) (sy +. sh) t'
|
||||
in
|
||||
let vx = Interval.make vx1 vx2
|
||||
and vy = Interval.make vy1 vy2 in
|
||||
let image =
|
||||
resize_canvas vg sw sh
|
||||
(I.crop ~l:sx ~t:sy cache.image)
|
||||
in
|
||||
{ vx; vy; image }
|
||||
| X (a, b) ->
|
||||
let aw, bw = split ~a:a.w ~sa:a.sw ~b:b.w ~sb:b.sw sw in
|
||||
let ca = render_node vg vx1 vy1 vx2 vy2 aw sh a in
|
||||
let cb =
|
||||
render_node vg (vx1 -. aw) vy1 (vx2 -. aw) vy2 bw sh b
|
||||
in
|
||||
let vx =
|
||||
Interval.make
|
||||
(max (Interval.fst ca.vx)
|
||||
(Interval.fst cb.vx +. aw))
|
||||
(min (Interval.snd ca.vx)
|
||||
(Interval.snd cb.vx +. aw))
|
||||
and vy =
|
||||
Interval.make
|
||||
(max (Interval.fst ca.vy) (Interval.fst cb.vy))
|
||||
(min (Interval.snd ca.vy) (Interval.snd cb.vy))
|
||||
and image =
|
||||
resize_canvas vg sw sh I.(ca.image <|> cb.image)
|
||||
in
|
||||
{ vx; vy; image }
|
||||
| Y (a, b) ->
|
||||
let ah, bh = split ~a:a.h ~sa:a.sh ~b:b.h ~sb:b.sh sh in
|
||||
let ca = render_node vg vx1 vy1 vx2 vy2 sw ah a in
|
||||
let cb =
|
||||
render_node vg vx1 (vy1 -. ah) vx2 (vy2 -. ah) sw bh b
|
||||
in
|
||||
let vx =
|
||||
Interval.make
|
||||
(max (Interval.fst ca.vx) (Interval.fst cb.vx))
|
||||
(min (Interval.snd ca.vx) (Interval.snd cb.vx))
|
||||
and vy =
|
||||
Interval.make
|
||||
(max (Interval.fst ca.vy)
|
||||
(Interval.fst cb.vy +. ah))
|
||||
(min (Interval.snd ca.vy)
|
||||
(Interval.snd cb.vy +. ah))
|
||||
and image =
|
||||
resize_canvas vg sw sh (I.( <-> ) ca.image cb.image)
|
||||
in
|
||||
{ vx; vy; image }
|
||||
| Z (a, b) ->
|
||||
let ca = render_node vg vx1 vy1 vx2 vy2 sw sh a in
|
||||
let cb = render_node vg vx1 vy1 vx2 vy2 sw sh b in
|
||||
let vx =
|
||||
Interval.make
|
||||
(max (Interval.fst ca.vx) (Interval.fst cb.vx))
|
||||
(min (Interval.snd ca.vx) (Interval.snd cb.vx))
|
||||
and vy =
|
||||
Interval.make
|
||||
(max (Interval.fst ca.vy) (Interval.fst cb.vy))
|
||||
(min (Interval.snd ca.vy) (Interval.snd cb.vy))
|
||||
and image =
|
||||
resize_canvas vg sw sh (I.( </> ) cb.image ca.image)
|
||||
in
|
||||
{ vx; vy; image }
|
||||
| Resize (t, _, _, g) ->
|
||||
let open Gravity in
|
||||
let dx, rw =
|
||||
pack ~fixed:t.w ~stretch:t.sw sw (h (p1 g)) (h (p2 g))
|
||||
in
|
||||
let dy, rh =
|
||||
pack ~fixed:t.h ~stretch:t.sh sh (v (p1 g)) (v (p2 g))
|
||||
in
|
||||
let c =
|
||||
render_node vg (vx1 -. dx) (vy1 -. dy) (vx2 -. dx)
|
||||
(vy2 -. dy) rw rh t
|
||||
in
|
||||
let image = resize_canvas2 vg dx dy sw sh c.image in
|
||||
let vx = Interval.shift c.vx dx in
|
||||
let vy = Interval.shift c.vy dy in
|
||||
{ vx; vy; image }
|
||||
| Event_filter (t, _f) ->
|
||||
render_node vg vx1 vy1 vx2 vy2 sw sh t
|
||||
in
|
||||
t.cache <- cache;
|
||||
cache
|
||||
|
||||
@ -2048,7 +2112,6 @@ module Nottui = struct
|
||||
in
|
||||
iter st'
|
||||
| Focus_area (t, f) -> (
|
||||
Log.debug (fun m -> m "dispatch_raw_key Focus_area");
|
||||
match iter [ t ] with
|
||||
| `Handled -> `Handled
|
||||
| `Unhandled -> (
|
||||
@ -2097,18 +2160,10 @@ module Nottui = struct
|
||||
| Event_filter (t, _) ->
|
||||
dispatch_focus t dir
|
||||
| Focus_area (t', _) ->
|
||||
if Focus.has_focus t'.focus then (
|
||||
Log.debug (fun m ->
|
||||
m "dispatch_focus: Focus.has_focus t'.focus");
|
||||
dispatch_focus t' dir || grab_focus t)
|
||||
else if
|
||||
Log.debug (fun m ->
|
||||
m "dispatch_focus: Focus.has_focus t.focus");
|
||||
Focus.has_focus t.focus
|
||||
then false
|
||||
else (
|
||||
Log.debug (fun m -> m "dispatch_focus: grab_focus");
|
||||
grab_focus t)
|
||||
if Focus.has_focus t'.focus then
|
||||
dispatch_focus t' dir || grab_focus t
|
||||
else if Focus.has_focus t.focus then false
|
||||
else grab_focus t
|
||||
| X (a, b) -> (
|
||||
if Focus.has_focus a.focus then
|
||||
dispatch_focus a dir
|
||||
@ -2228,7 +2283,6 @@ module Nottui_lwt = struct
|
||||
in
|
||||
refresh ();
|
||||
let process_event e =
|
||||
Log.debug (fun m -> m "Nottui_lwt.render= process_event");
|
||||
match e with
|
||||
| `Key (`Uchar c, [ `Meta ]) as event
|
||||
when Uchar.(equal c (of_char 'q')) -> (
|
||||
@ -2239,10 +2293,11 @@ module Nottui_lwt = struct
|
||||
match Renderer.dispatch_event renderer event with
|
||||
| `Handled -> ()
|
||||
| `Unhandled ->
|
||||
Log.warn (fun m ->
|
||||
(* Log.warn (fun m ->
|
||||
m
|
||||
"Nottui_lwt.render process_event #Ui.event -> \
|
||||
`Unhandled"))
|
||||
`Unhandled") *)
|
||||
())
|
||||
| `Resize size' ->
|
||||
size := size';
|
||||
refresh ()
|
||||
@ -2284,8 +2339,11 @@ module Nottui_widgets = struct
|
||||
|
||||
let attr_menu_main = A.(bg Color.green ++ fg Color.black)
|
||||
let attr_menu_sub = A.(bg Color.lightgreen ++ fg Color.black)
|
||||
let attr_clickable = A.(bg @@ Color.rgbf ~r:0.2 ~g:0.2 ~b:0.5)
|
||||
let attr_cursor = A.(bg @@ Color.rgbf ~r:0.4 ~g:0.4 ~b:0.1)
|
||||
|
||||
let attr_clickable =
|
||||
A.((bg @@ Color.rgbf ~r:0.2 ~g:0.2 ~b:0.5) ++ (fg @@ Color.light))
|
||||
|
||||
let attr_cursor = A.((fg @@ Color.dark) ++ (bg @@ Color.yellow))
|
||||
|
||||
type window_manager = {
|
||||
overlays : ui Lwd.t Lwd_table.t;
|
||||
@ -2397,73 +2455,6 @@ module Nottui_widgets = struct
|
||||
|
||||
let scroll_step = 7.
|
||||
|
||||
type scroll_state = {
|
||||
position : float;
|
||||
bound : float;
|
||||
visible : float;
|
||||
total : float;
|
||||
}
|
||||
|
||||
let default_scroll_state =
|
||||
{ position = 0.; bound = 0.; visible = 0.; total = 0. }
|
||||
|
||||
let pp_scroll_state ppf { position; bound; visible; total } =
|
||||
Format.fprintf ppf
|
||||
"{position=%.1f;@ bound=%.1f;@ visible=%.1f;@ total=%.1f}"
|
||||
position bound visible total
|
||||
|
||||
let vscroll_area ~state ~change (t : Ui.t Lwd.t) =
|
||||
let visible = ref (-1.) in
|
||||
let total = ref (-1.) in
|
||||
let scroll state delta =
|
||||
let position = state.position +. delta in
|
||||
let position = max 0. (min state.bound position) in
|
||||
if position <> state.position then
|
||||
change `Action { state with position };
|
||||
`Handled
|
||||
in
|
||||
let focus_handler state = function
|
||||
(*| `Arrow `Left , _ -> scroll (-scroll_step) 0*)
|
||||
(*| `Arrow `Right, _ -> scroll (+scroll_step) 0*)
|
||||
| `Arrow `Up, [] -> scroll state (-.scroll_step)
|
||||
| `Arrow `Down, [] -> scroll state (+.scroll_step)
|
||||
| `Page `Up, [] -> scroll state (-.scroll_step *. 8.)
|
||||
| `Page `Down, [] -> scroll state (+.scroll_step *. 8.)
|
||||
| _ -> `Unhandled
|
||||
in
|
||||
let scroll_handler state ~x:_ ~y:_ = function
|
||||
| `Scroll `Up -> scroll state (-.scroll_step)
|
||||
| `Scroll `Down -> scroll state (+.scroll_step)
|
||||
| _ -> `Unhandled
|
||||
in
|
||||
Lwd.map2 t state ~f:(fun t state ->
|
||||
t
|
||||
|> Ui.shift_area 0. state.position
|
||||
|> Ui.resize ~h:0. ~sh:1.
|
||||
|> Ui.size_sensor (fun ~w:_ ~h ->
|
||||
let tchange =
|
||||
if !total <> Ui.(layout_spec t).h then (
|
||||
total := Ui.(layout_spec t).h;
|
||||
true)
|
||||
else false
|
||||
in
|
||||
let vchange =
|
||||
if !visible <> h then (
|
||||
visible := h;
|
||||
true)
|
||||
else false
|
||||
in
|
||||
if tchange || vchange then
|
||||
change `Content
|
||||
{
|
||||
state with
|
||||
visible = !visible;
|
||||
total = !total;
|
||||
bound = max 0. (!total -. !visible);
|
||||
})
|
||||
|> Ui.mouse_area (scroll_handler state)
|
||||
|> Ui.keyboard_area (focus_handler state))
|
||||
|
||||
let scroll_area ?(offset = (0., 0.)) t =
|
||||
let offset = Lwd.var offset in
|
||||
let scroll d_x d_y =
|
||||
@ -2637,12 +2628,9 @@ module Nottui_widgets = struct
|
||||
let sub' str p l =
|
||||
if p = 0 && l = String.length str then str else String.sub str p l
|
||||
|
||||
let edit_field ?(focus = Focus.make ()) ?(on_change = ignore)
|
||||
let edit_field ?(focus = Focus.make ()) ?(on_change = Fun.id)
|
||||
?(on_submit = ignore) state =
|
||||
let on_change a =
|
||||
on_change a;
|
||||
Lwd.set state a
|
||||
in
|
||||
let on_change a = Lwd.set state (on_change a) in
|
||||
let update focus_h focus (text, pos) =
|
||||
let pos = min (max 0 pos) (String.length text) in
|
||||
let content =
|
||||
@ -2651,25 +2639,18 @@ module Nottui_widgets = struct
|
||||
if Focus.has_focus focus then
|
||||
let attr = attr_clickable in
|
||||
let len = String.length text in
|
||||
(if pos >= len then [ I.string ~attr text ]
|
||||
else [ I.string ~attr (sub' text 0 pos) ])
|
||||
@
|
||||
if pos < String.length text then
|
||||
if pos >= len then
|
||||
[ I.string ~attr text; I.string ~attr:attr_cursor " " ]
|
||||
else
|
||||
[
|
||||
I.string ~attr (sub' text 0 pos);
|
||||
I.string ~attr:attr_cursor (sub' text pos 1);
|
||||
I.string ~attr (sub' text (pos + 1) (len - pos - 1));
|
||||
]
|
||||
else [ I.string ~attr:A.(bg Color.lightred) " " ]
|
||||
else
|
||||
[
|
||||
I.string
|
||||
~attr:A.(font Font.underline)
|
||||
(if text = "" then " " else text);
|
||||
]
|
||||
else [ I.string (if text = "" then " " else text) ]
|
||||
in
|
||||
let handler k =
|
||||
(* Log.debug (fun m -> m "edit_field keyboard_area handler");*)
|
||||
match k with
|
||||
(match k with
|
||||
| `Uchar c, [ `Ctrl ] when Uchar.(equal c (of_char 'U')) ->
|
||||
on_change ("", 0);
|
||||
`Handled (* clear *)
|
||||
@ -2715,7 +2696,12 @@ module Nottui_widgets = struct
|
||||
on_change (text, pos);
|
||||
`Handled)
|
||||
else `Unhandled
|
||||
| _ -> `Unhandled
|
||||
| _ -> `Unhandled)
|
||||
|> fun r ->
|
||||
Log.debug (fun m ->
|
||||
m "edit_field keyboard_area handler %a -> %a" Ui.pp_key k
|
||||
Ui.pp_may_handle r);
|
||||
r
|
||||
in
|
||||
Ui.keyboard_area ~focus handler content
|
||||
in
|
||||
@ -2735,6 +2721,95 @@ module Nottui_widgets = struct
|
||||
|
||||
open Lwd.Infix
|
||||
|
||||
type line = {
|
||||
focus : Focus.handle;
|
||||
state : (string * int) Lwd.var;
|
||||
ui : Ui.t Lwd.t;
|
||||
}
|
||||
|
||||
let _line_on_change _table _row (s, i) = (s, i)
|
||||
let eq_uc_c uc c = Uchar.(equal uc (of_char c))
|
||||
|
||||
let copy_line_cursor (x : line) (y : line) =
|
||||
let _, xi = Lwd.peek x.state in
|
||||
let ys, _ = Lwd.peek y.state in
|
||||
let yi = Int.max 0 (Int.min xi (String.length ys)) in
|
||||
Lwd.set y.state (ys, yi)
|
||||
|
||||
let cursor_move cursor
|
||||
(f : line Lwd_table.row -> line Lwd_table.row option) =
|
||||
match Lwd.peek cursor with
|
||||
| Some cursor_line -> (
|
||||
match f cursor_line with
|
||||
| Some new_line ->
|
||||
(match Lwd_table.get new_line with
|
||||
| Some line' ->
|
||||
cursor_line |> Lwd_table.get
|
||||
|> Option.iter (fun line ->
|
||||
copy_line_cursor line line');
|
||||
Focus.request line'.focus
|
||||
| None -> ());
|
||||
Lwd.set cursor (Some new_line);
|
||||
`Handled
|
||||
| None -> `Unhandled)
|
||||
| None -> `Unhandled
|
||||
|
||||
let line_append ?(table = Lwd_table.make ()) str =
|
||||
let focus = Focus.make () in
|
||||
let state = Lwd.var (str, 0) in
|
||||
let row = Lwd_table.append table in
|
||||
Lwd_table.set row
|
||||
{
|
||||
focus;
|
||||
state;
|
||||
ui =
|
||||
edit_field ~focus
|
||||
~on_change:(_line_on_change table row)
|
||||
state;
|
||||
}
|
||||
|
||||
let line_table_of_string ?(table = Lwd_table.make ())
|
||||
?(focus = Focus.make ()) (s : string) : Ui.t Lwd.t =
|
||||
(* Append lines from s to table *)
|
||||
List.iter (line_append ~table) (String.split_on_char '\n' s);
|
||||
(* create the cursor var *)
|
||||
let cursor = Lwd.var @@ Lwd_table.first table in
|
||||
Option.iter
|
||||
(fun cursor ->
|
||||
Option.iter (fun first -> Focus.request first.focus)
|
||||
@@ Lwd_table.get cursor)
|
||||
(Lwd.peek cursor);
|
||||
|
||||
(* Build view of table *)
|
||||
Lwd_table.map_reduce
|
||||
(fun _ { ui; _ } -> ui)
|
||||
(Lwd_utils.lift_monoid Ui.pack_y)
|
||||
table
|
||||
|> Lwd.join
|
||||
|> Lwd.map2
|
||||
~f:(fun focus ->
|
||||
Ui.keyboard_area ~focus (function
|
||||
| `Uchar u, [ `Ctrl ] when eq_uc_c u 'n' ->
|
||||
cursor_move cursor (fun c -> Lwd_table.next c)
|
||||
| `Arrow `Down, _ ->
|
||||
cursor_move cursor (fun c -> Lwd_table.next c)
|
||||
| `Uchar u, [ `Ctrl ] when eq_uc_c u 'p' ->
|
||||
cursor_move cursor (fun c -> Lwd_table.prev c)
|
||||
| `Arrow `Up, _ ->
|
||||
cursor_move cursor (fun c -> Lwd_table.prev c)
|
||||
| `Uchar u, [ `Meta ] when eq_uc_c u '<' ->
|
||||
cursor_move cursor (fun _ -> Lwd_table.first table)
|
||||
| `Uchar u, [ `Meta ] when eq_uc_c u '>' ->
|
||||
cursor_move cursor (fun _ -> Lwd_table.last table)
|
||||
(* | `Enter, [] -> (
|
||||
let row = Lwd.peek cursor in
|
||||
match Lwd_table.get row with
|
||||
| Some line ->
|
||||
Lwd_table.after row ~set:Lwd.set cursor
|
||||
| None -> `Unhandled) *)
|
||||
| _ -> `Unhandled))
|
||||
(Focus.status focus)
|
||||
|
||||
(** Tab view, where exactly one element of [l] is shown at a time. *)
|
||||
let tabs (tabs : (string * (unit -> Ui.t Lwd.t)) list) : Ui.t Lwd.t
|
||||
=
|
||||
|
||||
@ -24,6 +24,14 @@
|
||||
* principles?
|
||||
an "anywhere" programming environment
|
||||
|
||||
* 221211
|
||||
ok you got the scroll box mostly working so next:
|
||||
** fix the scroll jump bugs
|
||||
** setup better keybindings
|
||||
** fix cursor and active focus indicators
|
||||
|
||||
|
||||
|
||||
* 221210 -
|
||||
** need to resolve the issue with the ui.t Resize type.
|
||||
this is an issue with the direction of the determination of the .height and .width fields of Ui.t
|
||||
|
||||
Reference in New Issue
Block a user