A lightweight reactive document library.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 

858 lines
26 KiB

  1. open Notty
  2. let maxi x y : int = if x > y then x else y
  3. let mini x y : int = if x < y then x else y
  4. module Focus :
  5. sig
  6. type var = int Lwd.var
  7. type handle
  8. val make : unit -> handle
  9. val request : handle -> unit
  10. val request_var : var -> unit
  11. val release : handle -> unit
  12. type status =
  13. | Empty
  14. | Handle of int * var
  15. | Conflict of int
  16. val empty : status
  17. (*val is_empty : status -> bool*)
  18. val status : handle -> status Lwd.t
  19. val has_focus : status -> bool
  20. val merge : status -> status -> status
  21. end = struct
  22. type var = int Lwd.var
  23. type status =
  24. | Empty
  25. | Handle of int * var
  26. | Conflict of int
  27. type handle = var * status Lwd.t
  28. let make () =
  29. let v = Lwd.var 0 in
  30. (v, Lwd.map (fun i -> Handle (i, v)) (Lwd.get v))
  31. let empty : status = Empty
  32. let status (h : handle) : status Lwd.t = snd h
  33. let has_focus = function
  34. | Empty -> false
  35. | Handle (i, _) | Conflict i -> i > 0
  36. let clock = ref 0
  37. let request_var (v : var) =
  38. incr clock;
  39. Lwd.set v !clock
  40. let request (v, _ : handle) = request_var v
  41. let release (v, _ : handle) = incr clock; Lwd.set v 0
  42. let merge s1 s2 : status = match s1, s2 with
  43. | Empty, x | x, Empty -> x
  44. | _, Handle (0, _) -> s1
  45. | Handle (0, _), _ -> s2
  46. | Handle (i1, _), Handle (i2, _) when i1 = i2 -> s1
  47. | (Handle (i1, _) | Conflict i1), Conflict i2 when i1 < i2 -> s2
  48. | (Handle (i1, _) | Conflict i1), Handle (i2, _) when i1 < i2 ->
  49. Conflict i2
  50. | Conflict _, (Handle (_, _) | Conflict _) -> s1
  51. | Handle (i1, _), (Handle (_, _) | Conflict _) -> Conflict i1
  52. end
  53. module Gravity :
  54. sig
  55. type direction = [
  56. | `Negative
  57. | `Neutral
  58. | `Positive
  59. ]
  60. val pp_direction : Format.formatter -> direction -> unit
  61. type t
  62. val pp : Format.formatter -> t -> unit
  63. val make : h:direction -> v:direction -> t
  64. val default : t
  65. val h : t -> direction
  66. val v : t -> direction
  67. type t2
  68. val pair : t -> t -> t2
  69. val p1 : t2 -> t
  70. val p2 : t2 -> t
  71. end =
  72. struct
  73. type direction = [ `Negative | `Neutral | `Positive ]
  74. type t = int
  75. type t2 = int
  76. let default = 0
  77. let pack = function
  78. | `Negative -> 0
  79. | `Neutral -> 1
  80. | `Positive -> 2
  81. let unpack = function
  82. | 0 -> `Negative
  83. | 1 -> `Neutral
  84. | _ -> `Positive
  85. let make ~h ~v =
  86. (pack h lsl 2) lor pack v
  87. let h x = unpack (x lsr 2)
  88. let v x = unpack (x land 3)
  89. let pp_direction ppf dir =
  90. let text = match dir with
  91. | `Negative -> "`Negative"
  92. | `Neutral -> "`Neutral"
  93. | `Positive -> "`Positive"
  94. in
  95. Format.pp_print_string ppf text
  96. let pp ppf g =
  97. Format.fprintf ppf "{ h = %a; v = %a }" pp_direction (h g) pp_direction (v g)
  98. let pair t1 t2 =
  99. (t1 lsl 4) lor t2
  100. let p1 t = (t lsr 4) land 15
  101. let p2 t = t land 15
  102. end
  103. type gravity = Gravity.t
  104. module Interval : sig
  105. type t = private int
  106. val make : int -> int -> t
  107. val shift : t -> int -> t
  108. val fst : t -> int
  109. val snd : t -> int
  110. (*val size : t -> int*)
  111. val zero : t
  112. end = struct
  113. type t = int
  114. let half = Sys.word_size lsr 1
  115. let mask = (1 lsl half) - 1
  116. let make x y =
  117. let size = y - x in
  118. (*assert (size >= 0);*)
  119. (x lsl half) lor (size land mask)
  120. let shift t d =
  121. t + d lsl half
  122. let fst t = t asr half
  123. let size t = t land mask
  124. let snd t = fst t + size t
  125. let zero = 0
  126. end
  127. module Ui =
  128. struct
  129. type may_handle = [ `Unhandled | `Handled ]
  130. type mouse_handler = x:int -> y:int -> Unescape.button -> [
  131. | `Unhandled
  132. | `Handled
  133. | `Grab of (x:int -> y:int -> unit) * (x:int -> y:int -> unit)
  134. ]
  135. type semantic_key = [
  136. (* Clipboard *)
  137. | `Copy
  138. | `Paste
  139. (* Focus management *)
  140. | `Focus of [`Next | `Prev | `Left | `Right | `Up | `Down]
  141. ]
  142. type key = [
  143. | Unescape.special | `Uchar of Uchar.t | `ASCII of char | semantic_key
  144. ] * Unescape.mods
  145. type mouse = Unescape.mouse
  146. type event = [ `Key of key | `Mouse of mouse | `Paste of Unescape.paste ]
  147. type layout_spec = { w : int; h : int; sw : int; sh : int }
  148. let pp_layout_spec ppf { w; h; sw; sh } =
  149. Format.fprintf ppf "{ w = %d; h = %d; sw = %d; sh = %d }" w h sw sh
  150. type flags = int
  151. let flags_none = 0
  152. let flag_transient_sensor = 1
  153. let flag_permanent_sensor = 2
  154. type size_sensor = w:int -> h:int -> unit
  155. type frame_sensor = x:int -> y:int -> w:int -> h:int -> unit -> unit
  156. type t = {
  157. w : int; sw : int;
  158. h : int; sh : int;
  159. mutable desc : desc;
  160. focus : Focus.status;
  161. mutable flags : flags;
  162. mutable sensor_cache : (int * int * int * int) option;
  163. mutable cache : cache;
  164. }
  165. and cache = {
  166. vx : Interval.t; vy : Interval.t;
  167. image : image;
  168. }
  169. and desc =
  170. | Atom of image
  171. | Size_sensor of t * size_sensor
  172. | Transient_sensor of t * frame_sensor
  173. | Permanent_sensor of t * frame_sensor
  174. | Resize of t * Gravity.t2 * A.t
  175. | Mouse_handler of t * mouse_handler
  176. | Focus_area of t * (key -> may_handle)
  177. | Shift_area of t * int * int
  178. | Event_filter of t * ([`Key of key | `Mouse of mouse] -> may_handle)
  179. | X of t * t
  180. | Y of t * t
  181. | Z of t * t
  182. let layout_spec t : layout_spec =
  183. { w = t.w; h = t.h; sw = t.sw; sh = t.sh }
  184. let layout_width t = t.w
  185. let layout_stretch_width t = t.sw
  186. let layout_height t = t.h
  187. let layout_stretch_height t = t.sh
  188. let cache : cache =
  189. { vx = Interval.zero; vy = Interval.zero; image = I.empty }
  190. let empty : t =
  191. { w = 0; sw = 0; h = 0; sh = 0; flags = flags_none;
  192. focus = Focus.empty; desc = Atom I.empty;
  193. sensor_cache = None; cache }
  194. let atom img : t =
  195. { w = I.width img; sw = 0;
  196. h = I.height img; sh = 0;
  197. focus = Focus.empty; flags = flags_none;
  198. desc = Atom img;
  199. sensor_cache = None; cache; }
  200. let space x y = atom (I.void x y)
  201. let mouse_area f t : t =
  202. { t with desc = Mouse_handler (t, f) }
  203. let keyboard_area ?focus f t : t =
  204. let focus = match focus with
  205. | None -> t.focus
  206. | Some focus -> Focus.merge focus t.focus
  207. in
  208. { t with desc = Focus_area (t, f); focus }
  209. let shift_area x y t : t =
  210. { t with desc = Shift_area (t, x, y) }
  211. let size_sensor handler t : t =
  212. { t with desc = Size_sensor (t, handler) }
  213. let transient_sensor frame_sensor t =
  214. { t with desc = Transient_sensor (t, frame_sensor);
  215. flags = t.flags lor flag_transient_sensor }
  216. let permanent_sensor frame_sensor t =
  217. { t with desc = Permanent_sensor (t, frame_sensor);
  218. flags = t.flags lor flag_permanent_sensor }
  219. let resize ?w ?h ?sw ?sh ?pad ?crop ?(bg=A.empty) t : t =
  220. let g = match pad, crop with
  221. | None, None -> Gravity.(pair default default)
  222. | Some g, None | None, Some g -> Gravity.(pair g g)
  223. | Some pad, Some crop -> Gravity.(pair pad crop)
  224. in
  225. match (w, t.w), (h, t.h), (sw, t.sw), (sh, t.sh) with
  226. | (Some w, _ | None, w), (Some h, _ | None, h),
  227. (Some sw, _ | None, sw), (Some sh, _ | None, sh) ->
  228. {t with w; h; sw; sh; desc = Resize (t, g, bg)}
  229. let event_filter ?focus f t : t =
  230. let focus = match focus with
  231. | None -> t.focus
  232. | Some focus -> focus
  233. in
  234. { t with desc = Event_filter (t, f); focus }
  235. let join_x a b = {
  236. w = (a.w + b.w); sw = (a.sw + b.sw);
  237. h = (maxi a.h b.h); sh = (maxi a.sh b.sh);
  238. flags = a.flags lor b.flags;
  239. focus = Focus.merge a.focus b.focus; desc = X (a, b);
  240. sensor_cache = None; cache
  241. }
  242. let join_y a b = {
  243. w = (maxi a.w b.w); sw = (maxi a.sw b.sw);
  244. h = (a.h + b.h); sh = (a.sh + b.sh);
  245. flags = a.flags lor b.flags;
  246. focus = Focus.merge a.focus b.focus; desc = Y (a, b);
  247. sensor_cache = None; cache;
  248. }
  249. let join_z a b = {
  250. w = (maxi a.w b.w); sw = (maxi a.sw b.sw);
  251. h = (maxi a.h b.h); sh = (maxi a.sh b.sh);
  252. flags = a.flags lor b.flags;
  253. focus = Focus.merge a.focus b.focus; desc = Z (a, b);
  254. sensor_cache = None; cache;
  255. }
  256. let pack_x = (empty, join_x)
  257. let pack_y = (empty, join_y)
  258. let pack_z = (empty, join_z)
  259. let hcat xs = Lwd_utils.reduce pack_x xs
  260. let vcat xs = Lwd_utils.reduce pack_y xs
  261. let zcat xs = Lwd_utils.reduce pack_z xs
  262. let has_focus t = Focus.has_focus t.focus
  263. let rec pp ppf t =
  264. Format.fprintf ppf
  265. "@[<hov>{@ w = %d;@ h = %d;@ sw = %d;@ sh = %d;@ desc = @[%a@];@ }@]"
  266. t.w t.h t.sw t.sh pp_desc t.desc
  267. and pp_desc ppf = function
  268. | Atom _ -> Format.fprintf ppf "Atom _"
  269. | Size_sensor (desc, _) ->
  270. Format.fprintf ppf "Size_sensor (@[%a,@ _@])" pp desc
  271. | Transient_sensor (desc, _) ->
  272. Format.fprintf ppf "Transient_sensor (@[%a,@ _@])" pp desc
  273. | Permanent_sensor (desc, _) ->
  274. Format.fprintf ppf "Permanent_sensor (@[%a,@ _@])" pp desc
  275. | Resize (desc, gravity, _bg) ->
  276. Format.fprintf ppf "Resize (@[%a,@ %a,@ %a@])" pp desc
  277. Gravity.pp (Gravity.p1 gravity)
  278. Gravity.pp (Gravity.p2 gravity)
  279. | Mouse_handler (n, _) ->
  280. Format.fprintf ppf "Mouse_handler (@[%a,@ _@])" pp n
  281. | Focus_area (n, _) ->
  282. Format.fprintf ppf "Focus_area (@[%a,@ _@])" pp n
  283. | Shift_area (n, _, _) ->
  284. Format.fprintf ppf "Shift_area (@[%a,@ _@])" pp n
  285. | Event_filter (n, _) ->
  286. Format.fprintf ppf "Event_filter (@[%a,@ _@])" pp n
  287. | X (a, b) -> Format.fprintf ppf "X (@[%a,@ %a@])" pp a pp b
  288. | Y (a, b) -> Format.fprintf ppf "Y (@[%a,@ %a@])" pp a pp b
  289. | Z (a, b) -> Format.fprintf ppf "Z (@[%a,@ %a@])" pp a pp b
  290. let iter f ui = match ui.desc with
  291. | Atom _ -> ()
  292. | Size_sensor (u, _) | Transient_sensor (u, _) | Permanent_sensor (u, _)
  293. | Resize (u, _, _) | Mouse_handler (u, _)
  294. | Focus_area (u, _) | Shift_area (u, _, _) | Event_filter (u, _)
  295. -> f u
  296. | X (u1, u2) | Y (u1, u2) | Z (u1, u2) -> f u1; f u2
  297. end
  298. type ui = Ui.t
  299. module Renderer =
  300. struct
  301. open Ui
  302. type size = int * int
  303. type grab_function = (x:int -> y:int -> unit) * (x:int -> y:int -> unit)
  304. type t = {
  305. mutable size : size;
  306. mutable view : ui;
  307. mutable mouse_grab : grab_function option;
  308. }
  309. let make () = {
  310. mouse_grab = None;
  311. size = (0, 0);
  312. view = Ui.empty;
  313. }
  314. let size t = t.size
  315. let solve_focus ui i =
  316. let rec aux ui =
  317. match ui.focus with
  318. | Focus.Empty | Focus.Handle (0, _) -> ()
  319. | Focus.Handle (i', _) when i = i' -> ()
  320. | Focus.Handle (_, v) -> Lwd.set v 0
  321. | Focus.Conflict _ -> Ui.iter aux ui
  322. in
  323. aux ui
  324. let split ~a ~sa ~b ~sb total =
  325. let stretch = sa + sb in
  326. let flex = total - a - b in
  327. if stretch > 0 && flex > 0 then
  328. let ratio =
  329. if sa > sb then
  330. flex * sa / stretch
  331. else
  332. flex - flex * sb / stretch
  333. in
  334. (a + ratio, b + flex - ratio)
  335. else
  336. (a, b)
  337. let pack ~fixed ~stretch total g1 g2 =
  338. let flex = total - fixed in
  339. if stretch > 0 && flex > 0 then
  340. (0, total)
  341. else
  342. let gravity = if flex >= 0 then g1 else g2 in
  343. match gravity with
  344. | `Negative -> (0, fixed)
  345. | `Neutral -> (flex / 2, fixed)
  346. | `Positive -> (flex, fixed)
  347. let has_transient_sensor flags = flags land flag_transient_sensor <> 0
  348. let has_permanent_sensor flags = flags land flag_permanent_sensor <> 0
  349. let rec update_sensors ox oy sw sh ui =
  350. if has_transient_sensor ui.flags || (
  351. has_permanent_sensor ui.flags &&
  352. match ui.sensor_cache with
  353. | None -> false
  354. | Some (ox', oy', sw', sh') ->
  355. ox = ox' && oy = oy' && sw = sw' && sh = sh'
  356. )
  357. then (
  358. ui.flags <- ui.flags land lnot flag_transient_sensor;
  359. if has_permanent_sensor ui.flags then
  360. ui.sensor_cache <- Some (ox, oy, sw, sh);
  361. match ui.desc with
  362. | Atom _ -> ()
  363. | Size_sensor (t, _) | Mouse_handler (t, _)
  364. | Focus_area (t, _) | Event_filter (t, _) ->
  365. update_sensors ox oy sw sh t
  366. | Transient_sensor (t, sensor) ->
  367. ui.desc <- t.desc;
  368. let sensor = sensor ~x:ox ~y:oy ~w:sw ~h:sh in
  369. update_sensors ox oy sw sh t;
  370. sensor ()
  371. | Permanent_sensor (t, sensor) ->
  372. let sensor = sensor ~x:ox ~y:oy ~w:sw ~h:sh in
  373. update_sensors ox oy sw sh t;
  374. sensor ()
  375. | Resize (t, g, _) ->
  376. let open Gravity in
  377. let dx, rw = pack ~fixed:t.w ~stretch:t.sw sw (h (p1 g)) (h (p2 g)) in
  378. let dy, rh = pack ~fixed:t.h ~stretch:t.sh sh (v (p1 g)) (v (p2 g)) in
  379. update_sensors (ox + dx) (oy + dy) rw rh t
  380. | Shift_area (t, sx, sy) ->
  381. update_sensors (ox - sx) (oy - sy) sw sh t
  382. | X (a, b) ->
  383. let aw, bw = split ~a:a.w ~sa:a.sw ~b:b.w ~sb:b.sw sw in
  384. update_sensors ox oy aw sh a;
  385. update_sensors (ox + aw) oy bw sh b
  386. | Y (a, b) ->
  387. let ah, bh = split ~a:a.h ~sa:a.sh ~b:b.h ~sb:b.sh sh in
  388. update_sensors ox oy sw ah a;
  389. update_sensors ox (oy + ah) sw bh b
  390. | Z (a, b) ->
  391. update_sensors ox oy sw sh a;
  392. update_sensors ox oy sw sh b
  393. )
  394. let update_focus ui =
  395. match ui.focus with
  396. | Focus.Empty | Focus.Handle _ -> ()
  397. | Focus.Conflict i -> solve_focus ui i
  398. let update t size ui =
  399. t.size <- size;
  400. t.view <- ui;
  401. update_sensors 0 0 (fst size) (snd size) ui;
  402. update_focus ui
  403. let dispatch_mouse st x y btn w h t =
  404. let handle ox oy f =
  405. match f ~x:(x - ox) ~y:(y - oy) btn with
  406. | `Unhandled -> false
  407. | `Handled -> true
  408. | `Grab f -> st.mouse_grab <- Some f; true
  409. in
  410. let rec aux ox oy sw sh t =
  411. match t.desc with
  412. | Atom _ -> false
  413. | X (a, b) ->
  414. let aw, bw = split ~a:a.w ~sa:a.sw ~b:b.w ~sb:b.sw sw in
  415. if x - ox < aw
  416. then aux ox oy aw sh a
  417. else aux (ox + aw) oy bw sh b
  418. | Y (a, b) ->
  419. let ah, bh = split ~a:a.h ~sa:a.sh ~b:b.h ~sb:b.sh sh in
  420. if y - oy < ah
  421. then aux ox oy sw ah a
  422. else aux ox (oy + ah) sw bh b
  423. | Z (a, b) ->
  424. aux ox oy sw sh b || aux ox oy sw sh a
  425. | Mouse_handler (t, f) ->
  426. let _offsetx, rw = pack ~fixed:t.w ~stretch:t.sw sw `Negative `Negative
  427. and _offsety, rh = pack ~fixed:t.h ~stretch:t.sh sh `Negative `Negative
  428. in
  429. assert (_offsetx = 0 && _offsety = 0);
  430. (x - ox >= 0 && x - ox <= rw && y - oy >= 0 && y - oy <= rh) &&
  431. (aux ox oy sw sh t || handle ox oy f)
  432. | Size_sensor (desc, _)
  433. | Transient_sensor (desc, _) | Permanent_sensor (desc, _)
  434. | Focus_area (desc, _) ->
  435. aux ox oy sw sh desc
  436. | Shift_area (desc, sx, sy) ->
  437. aux (ox - sx) (oy - sy) sw sh desc
  438. | Resize (t, g, _bg) ->
  439. let open Gravity in
  440. let dx, rw = pack ~fixed:t.w ~stretch:t.sw sw (h (p1 g)) (h (p2 g)) in
  441. let dy, rh = pack ~fixed:t.h ~stretch:t.sh sh (v (p1 g)) (v (p2 g)) in
  442. aux (ox + dx) (oy + dy) rw rh t
  443. | Event_filter (n, f) ->
  444. begin match f (`Mouse (`Press btn, (x, y), [])) with
  445. | `Handled -> true
  446. | `Unhandled -> aux ox oy sw sh n
  447. end
  448. in
  449. aux 0 0 w h t
  450. let release_grab st x y =
  451. match st.mouse_grab with
  452. | None -> ()
  453. | Some (_, release) ->
  454. st.mouse_grab <- None;
  455. release ~x ~y
  456. let dispatch_mouse t (event, (x, y), _mods) =
  457. if
  458. match event with
  459. | `Press btn ->
  460. release_grab t x y;
  461. let w, h = t.size in
  462. dispatch_mouse t x y btn w h t.view
  463. | `Drag ->
  464. begin match t.mouse_grab with
  465. | None -> false
  466. | Some (drag, _) -> drag ~x ~y; true
  467. end
  468. | `Release ->
  469. release_grab t x y; true
  470. then `Handled
  471. else `Unhandled
  472. let resize_canvas rw rh image =
  473. let w = I.width image in
  474. let h = I.height image in
  475. if w <> rw || h <> rh
  476. then I.pad ~r:(rw - w) ~b:(rh - h) image
  477. else image
  478. let resize_canvas2 ox oy rw rh image =
  479. let w = I.width image in
  480. let h = I.height image in
  481. I.pad ~l:ox ~t:oy ~r:(rw - w - ox) ~b:(rh - h - oy) image
  482. let same_size w h image =
  483. w = I.width image &&
  484. h = I.height image
  485. let rec render_node vx1 vy1 vx2 vy2 sw sh t : cache =
  486. if
  487. let cache = t.cache in
  488. vx1 >= Interval.fst cache.vx && vy1 >= Interval.fst cache.vy &&
  489. vx2 <= Interval.snd cache.vx && vy2 <= Interval.snd cache.vy &&
  490. same_size sw sh cache.image
  491. then t.cache
  492. else if vx2 < 0 || vy2 < 0 || sw < vx1 || sh < vy1 then
  493. let vx = Interval.make vx1 vx2 and vy = Interval.make vy1 vy2 in
  494. { vx; vy; image = I.void sw sh }
  495. else
  496. let cache = match t.desc with
  497. | Atom image ->
  498. { vx = Interval.make 0 sw;
  499. vy = Interval.make 0 sh;
  500. image = resize_canvas sw sh image }
  501. | Size_sensor (desc, handler) ->
  502. handler ~w:sw ~h:sh;
  503. render_node vx1 vy1 vx2 vy2 sw sh desc
  504. | Transient_sensor (desc, _) | Permanent_sensor (desc, _) ->
  505. render_node vx1 vy1 vx2 vy2 sw sh desc
  506. | Focus_area (desc, _) | Mouse_handler (desc, _) ->
  507. render_node vx1 vy1 vx2 vy2 sw sh desc
  508. | Shift_area (t', sx, sy) ->
  509. let cache = render_node
  510. (vx1 + sx) (vy1 + sy) (vx2 + sx) (vy2 + sy) (sx + sw) (sy + sh) t'
  511. in
  512. let vx = Interval.make vx1 vx2 and vy = Interval.make vy1 vy2 in
  513. let image = resize_canvas sw sh (I.crop ~l:sx ~t:sy cache.image) in
  514. { vx; vy; image }
  515. | X (a, b) ->
  516. let aw, bw = split ~a:a.w ~sa:a.sw ~b:b.w ~sb:b.sw sw in
  517. let ca = render_node vx1 vy1 vx2 vy2 aw sh a in
  518. let cb = render_node (vx1 - aw) vy1 (vx2 - aw) vy2 bw sh b in
  519. let vx = Interval.make
  520. (maxi (Interval.fst ca.vx) (Interval.fst cb.vx + aw))
  521. (mini (Interval.snd ca.vx) (Interval.snd cb.vx + aw))
  522. and vy = Interval.make
  523. (maxi (Interval.fst ca.vy) (Interval.fst cb.vy))
  524. (mini (Interval.snd ca.vy) (Interval.snd cb.vy))
  525. and image = resize_canvas sw sh (I.(<|>) ca.image cb.image) in
  526. { vx; vy; image }
  527. | Y (a, b) ->
  528. let ah, bh = split ~a:a.h ~sa:a.sh ~b:b.h ~sb:b.sh sh in
  529. let ca = render_node vx1 vy1 vx2 vy2 sw ah a in
  530. let cb = render_node vx1 (vy1 - ah) vx2 (vy2 - ah) sw bh b in
  531. let vx = Interval.make
  532. (maxi (Interval.fst ca.vx) (Interval.fst cb.vx))
  533. (mini (Interval.snd ca.vx) (Interval.snd cb.vx))
  534. and vy = Interval.make
  535. (maxi (Interval.fst ca.vy) (Interval.fst cb.vy + ah))
  536. (mini (Interval.snd ca.vy) (Interval.snd cb.vy + ah))
  537. and image = resize_canvas sw sh (I.(<->) ca.image cb.image) in
  538. { vx; vy; image }
  539. | Z (a, b) ->
  540. let ca = render_node vx1 vy1 vx2 vy2 sw sh a in
  541. let cb = render_node vx1 vy1 vx2 vy2 sw sh b in
  542. let vx = Interval.make
  543. (maxi (Interval.fst ca.vx) (Interval.fst cb.vx))
  544. (mini (Interval.snd ca.vx) (Interval.snd cb.vx))
  545. and vy = Interval.make
  546. (maxi (Interval.fst ca.vy) (Interval.fst cb.vy))
  547. (mini (Interval.snd ca.vy) (Interval.snd cb.vy))
  548. and image = resize_canvas sw sh (I.(</>) cb.image ca.image) in
  549. { vx; vy; image }
  550. | Resize (t, g, bg) ->
  551. let open Gravity in
  552. let dx, rw = pack ~fixed:t.w ~stretch:t.sw sw (h (p1 g)) (h (p2 g)) in
  553. let dy, rh = pack ~fixed:t.h ~stretch:t.sh sh (v (p1 g)) (v (p2 g)) in
  554. let c =
  555. render_node (vx1 - dx) (vy1 - dy) (vx2 - dx) (vy2 - dy) rw rh t
  556. in
  557. let image = resize_canvas2 dx dy sw sh c.image in
  558. let image =
  559. if bg != A.empty then
  560. I.(image </> char bg ' ' sw sh)
  561. else
  562. image
  563. in
  564. let vx = Interval.shift c.vx dx in
  565. let vy = Interval.shift c.vy dy in
  566. { vx; vy; image }
  567. | Event_filter (t, _f) ->
  568. render_node vx1 vy1 vx2 vy2 sw sh t
  569. in
  570. t.cache <- cache;
  571. cache
  572. let image {size = (w, h); view; _} =
  573. (render_node 0 0 w h w h view).image
  574. let dispatch_raw_key st key =
  575. let rec iter (st: ui list) : [> `Unhandled] =
  576. match st with
  577. | [] -> `Unhandled
  578. | ui :: tl ->
  579. begin match ui.desc with
  580. | Atom _ -> iter tl
  581. | X (a, b) | Y (a, b) | Z (a, b) ->
  582. (* Try left/top most branch first *)
  583. let st' =
  584. if Focus.has_focus b.focus
  585. then b :: tl
  586. else a :: b :: tl
  587. in
  588. iter st'
  589. | Focus_area (t, f) ->
  590. begin match iter [t] with
  591. | `Handled -> `Handled
  592. | `Unhandled ->
  593. match f key with
  594. | `Handled -> `Handled
  595. | `Unhandled -> iter tl
  596. end
  597. | Mouse_handler (t, _) | Size_sensor (t, _)
  598. | Transient_sensor (t, _) | Permanent_sensor (t, _)
  599. | Shift_area (t, _, _) | Resize (t, _, _) ->
  600. iter (t :: tl)
  601. | Event_filter (t, f) ->
  602. begin match f (`Key key) with
  603. | `Unhandled -> iter (t :: tl)
  604. | `Handled -> `Handled
  605. end
  606. end
  607. in
  608. iter [st.view]
  609. exception Acquired_focus
  610. let grab_focus ui =
  611. let rec aux ui =
  612. match ui.focus with
  613. | Focus.Empty -> ()
  614. | Focus.Handle (_, v) -> Focus.request_var v; raise Acquired_focus
  615. | Focus.Conflict _ -> iter aux ui
  616. in
  617. try aux ui; false with Acquired_focus -> true
  618. let rec dispatch_focus t dir =
  619. match t.desc with
  620. | Atom _ -> false
  621. | Mouse_handler (t, _) | Size_sensor (t, _)
  622. | Transient_sensor (t, _) | Permanent_sensor (t, _)
  623. | Shift_area (t, _, _) | Resize (t, _, _) | Event_filter (t, _) ->
  624. dispatch_focus t dir
  625. | Focus_area (t', _) ->
  626. if Focus.has_focus t'.focus then
  627. dispatch_focus t' dir || grab_focus t
  628. else if Focus.has_focus t.focus then
  629. false
  630. else
  631. grab_focus t
  632. | X (a, b) ->
  633. begin if Focus.has_focus a.focus then
  634. dispatch_focus a dir ||
  635. (match dir with
  636. | `Next | `Right -> dispatch_focus b dir
  637. | _ -> false
  638. )
  639. else if Focus.has_focus b.focus then
  640. dispatch_focus b dir ||
  641. (match dir with
  642. | `Prev | `Left -> dispatch_focus a dir
  643. | _ -> false
  644. )
  645. else
  646. match dir with
  647. | `Prev | `Left | `Up -> dispatch_focus b dir || dispatch_focus a dir
  648. | `Next | `Down | `Right -> dispatch_focus a dir || dispatch_focus b dir
  649. end
  650. | Y (a, b) ->
  651. begin if Focus.has_focus a.focus then
  652. dispatch_focus a dir ||
  653. (match dir with
  654. | `Next | `Down -> dispatch_focus b dir
  655. | _ -> false
  656. )
  657. else if Focus.has_focus b.focus then
  658. dispatch_focus b dir ||
  659. (match dir with
  660. | `Prev | `Up -> dispatch_focus a dir
  661. | _ -> false
  662. )
  663. else match dir with
  664. | `Prev | `Up -> dispatch_focus b dir || dispatch_focus a dir
  665. | `Next | `Left | `Down | `Right -> dispatch_focus a dir || dispatch_focus b dir
  666. end
  667. | Z (a, b) ->
  668. if Focus.has_focus a.focus then
  669. dispatch_focus a dir
  670. else
  671. dispatch_focus b dir || dispatch_focus a dir
  672. let rec dispatch_key st key =
  673. match dispatch_raw_key st key, key with
  674. | `Handled, _ -> `Handled
  675. | `Unhandled, (`Arrow dir, [`Meta]) ->
  676. let dir : [`Down | `Left | `Right | `Up] :>
  677. [`Down | `Left | `Right | `Up | `Next | `Prev] = dir in
  678. dispatch_key st (`Focus dir, [`Meta])
  679. | `Unhandled, (`Tab, mods) ->
  680. let dir = if List.mem `Shift mods then `Prev else `Next in
  681. dispatch_key st (`Focus dir, mods)
  682. | `Unhandled, (`Focus dir, _) ->
  683. if dispatch_focus st.view dir then `Handled else `Unhandled
  684. | `Unhandled, _ -> `Unhandled
  685. let dispatch_event t = function
  686. | `Key key -> dispatch_key t key
  687. | `Mouse mouse -> dispatch_mouse t mouse
  688. | `Paste _ -> `Unhandled
  689. end
  690. module Ui_loop =
  691. struct
  692. open Notty_unix
  693. (* FIXME Uses of [quick_sample] and [quick_release] should be replaced by
  694. [sample] and [release] with the appropriate release management. *)
  695. let step ?(process_event=true) ?(timeout=(-1.0)) ~renderer term root =
  696. let size = Term.size term in
  697. let image =
  698. let rec stabilize () =
  699. let tree = Lwd.quick_sample root in
  700. Renderer.update renderer size tree;
  701. let image = Renderer.image renderer in
  702. if Lwd.is_damaged root
  703. then stabilize ()
  704. else image
  705. in
  706. stabilize ()
  707. in
  708. Term.image term image;
  709. if process_event then
  710. let i, _ = Term.fds term in
  711. let has_event =
  712. let rec select () =
  713. match Unix.select [i] [] [i] timeout with
  714. | [], [], [] -> false
  715. | _ -> true
  716. | exception (Unix.Unix_error (Unix.EINTR, _, _)) -> select ()
  717. in
  718. select ()
  719. in
  720. if has_event then
  721. match Term.event term with
  722. | `End -> ()
  723. | `Resize _ -> ()
  724. | #Unescape.event as event ->
  725. let event = (event : Unescape.event :> Ui.event) in
  726. ignore (Renderer.dispatch_event renderer event : [`Handled | `Unhandled])
  727. let run_with_term term ?tick_period ?(tick=ignore) ~renderer quit t =
  728. let quit = Lwd.observe (Lwd.get quit) in
  729. let root = Lwd.observe t in
  730. let rec loop () =
  731. let quit = Lwd.quick_sample quit in
  732. if not quit then (
  733. step ~process_event:true ?timeout:tick_period ~renderer term root;
  734. tick ();
  735. loop ()
  736. )
  737. in
  738. loop ();
  739. ignore (Lwd.quick_release root);
  740. ignore (Lwd.quick_release quit)
  741. let run ?tick_period ?tick ?term ?(renderer=Renderer.make ())
  742. ?quit t =
  743. let quit = match quit with
  744. | Some quit -> quit
  745. | None -> Lwd.var false
  746. in
  747. let t =
  748. t |> Lwd.map (Ui.event_filter (function
  749. | `Key (`ASCII 'Q', [`Ctrl]) -> Lwd.set quit true; `Handled
  750. | _ -> `Unhandled
  751. ))
  752. in
  753. match term with
  754. | Some term -> run_with_term term ?tick_period ?tick ~renderer quit t
  755. | None ->
  756. let term = Term.create () in
  757. run_with_term term ?tick_period ?tick ~renderer quit t;
  758. Term.release term
  759. end