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.
 
 

686 lines
21 KiB

  1. open Lwd_infix
  2. open Lwd.Infix
  3. open Notty
  4. open Nottui
  5. let (!$) x = Lwd.join (Lwd.get x)
  6. let empty_lwd = Lwd.return Ui.empty
  7. let string ?(attr=A.empty) str =
  8. let control_character_index str i =
  9. let len = String.length str in
  10. let i = ref i in
  11. while let i = !i in i < len && str.[i] >= ' ' do
  12. incr i;
  13. done;
  14. if !i = len then raise Not_found;
  15. !i
  16. in
  17. let rec split str i =
  18. match control_character_index str i with
  19. | j ->
  20. let img = I.string attr (String.sub str i (j - i)) in
  21. img :: split str (j + 1)
  22. | exception Not_found ->
  23. [I.string attr
  24. (if i = 0 then str
  25. else String.sub str i (String.length str - i))]
  26. in
  27. Ui.atom (I.vcat (split str 0))
  28. let int ?attr x = string ?attr (string_of_int x)
  29. let bool ?attr x = string ?attr (string_of_bool x)
  30. let float_ ?attr x = string ?attr (string_of_float x)
  31. let printf ?attr fmt =
  32. Printf.ksprintf (string ?attr) fmt
  33. let fmt ?attr fmt =
  34. Format.kasprintf (string ?attr) fmt
  35. let kprintf k ?attr fmt =
  36. Printf.ksprintf (fun str -> k (string ?attr str)) fmt
  37. let kfmt k ?attr fmt =
  38. Format.kasprintf (fun str -> k (string ?attr str)) fmt
  39. let attr_menu_main = A.(bg green ++ fg black)
  40. let attr_menu_sub = A.(bg lightgreen ++ fg black)
  41. let menu_overlay ?dx ?dy handler t =
  42. ignore (dx, dy, handler, t);
  43. assert false
  44. (*let placeholder = Lwd.return (Ui.space 1 0) in
  45. let body = Lwd_utils.pack Ui.pack_x [placeholder; t; placeholder] in
  46. let bg = Lwd.map' body @@ fun t ->
  47. let {Ui. w; h; _} = Ui.layout_spec t in
  48. Ui.atom (I.char A.(bg lightgreen) ' ' w h)
  49. in
  50. Lwd.map (Ui.overlay ?dx ?dy ~handler) (Lwd_utils.pack Ui.pack_z [bg; body])*)
  51. let scroll_step = 1
  52. type scroll_state = {
  53. position: int;
  54. bound : int;
  55. visible : int;
  56. total : int;
  57. }
  58. let default_scroll_state = { position = 0; bound = 0; visible = 0; total = 0 }
  59. let vscroll_area ~state ~change t =
  60. let visible = ref (-1) in
  61. let total = ref (-1) in
  62. let scroll state delta =
  63. let position = state.position + delta in
  64. let position = max 0 (min state.bound position) in
  65. if position <> state.position then
  66. change `Action {state with position};
  67. `Handled
  68. in
  69. let focus_handler state = function
  70. (*| `Arrow `Left , _ -> scroll (-scroll_step) 0*)
  71. (*| `Arrow `Right, _ -> scroll (+scroll_step) 0*)
  72. | `Arrow `Up , [] -> scroll state (-scroll_step)
  73. | `Arrow `Down , [] -> scroll state (+scroll_step)
  74. | `Page `Up, [] -> scroll state ((-scroll_step) * 8)
  75. | `Page `Down, [] -> scroll state ((+scroll_step) * 8)
  76. | _ -> `Unhandled
  77. in
  78. let scroll_handler state ~x:_ ~y:_ = function
  79. | `Scroll `Up -> scroll state (-scroll_step)
  80. | `Scroll `Down -> scroll state (+scroll_step)
  81. | _ -> `Unhandled
  82. in
  83. Lwd.map2' t state @@ fun t state ->
  84. t
  85. |> Ui.shift_area 0 state.position
  86. |> Ui.resize ~h:0 ~sh:1
  87. |> Ui.size_sensor (fun ~w:_ ~h ->
  88. let tchange =
  89. if !total <> (Ui.layout_spec t).Ui.h
  90. then (total := (Ui.layout_spec t).Ui.h; true)
  91. else false
  92. in
  93. let vchange =
  94. if !visible <> h
  95. then (visible := h; true)
  96. else false
  97. in
  98. if tchange || vchange then
  99. change `Content {state with visible = !visible; total = !total;
  100. bound = max 0 (!total - !visible); }
  101. )
  102. |> Ui.mouse_area (scroll_handler state)
  103. |> Ui.keyboard_area (focus_handler state)
  104. let scroll_area ?(offset=0,0) t =
  105. let offset = Lwd.var offset in
  106. let scroll d_x d_y =
  107. let s_x, s_y = Lwd.peek offset in
  108. let s_x = max 0 (s_x + d_x) in
  109. let s_y = max 0 (s_y + d_y) in
  110. Lwd.set offset (s_x, s_y);
  111. `Handled
  112. in
  113. let focus_handler = function
  114. | `Arrow `Left , [] -> scroll (-scroll_step) 0
  115. | `Arrow `Right, [] -> scroll (+scroll_step) 0
  116. | `Arrow `Up , [] -> scroll 0 (-scroll_step)
  117. | `Arrow `Down , [] -> scroll 0 (+scroll_step)
  118. | `Page `Up, [] -> scroll 0 ((-scroll_step) * 8)
  119. | `Page `Down, [] -> scroll 0 ((+scroll_step) * 8)
  120. | _ -> `Unhandled
  121. in
  122. let scroll_handler ~x:_ ~y:_ = function
  123. | `Scroll `Up -> scroll 0 (-scroll_step)
  124. | `Scroll `Down -> scroll 0 (+scroll_step)
  125. | _ -> `Unhandled
  126. in
  127. Lwd.map2' t (Lwd.get offset) @@ fun t (s_x, s_y) ->
  128. t
  129. |> Ui.shift_area s_x s_y
  130. |> Ui.mouse_area scroll_handler
  131. |> Ui.keyboard_area focus_handler
  132. let main_menu_item text f =
  133. let text = string ~attr:attr_menu_main (" " ^ text ^ " ") in
  134. let v = Lwd.var empty_lwd in
  135. let visible = ref false in
  136. let on_click ~x:_ ~y:_ = function
  137. | `Left ->
  138. visible := not !visible;
  139. if not !visible then (
  140. v $= Lwd.return Ui.empty
  141. ) else (
  142. let h ~x:_ ~y:_ = function
  143. | `Left ->
  144. visible := false; v $= Lwd.return Ui.empty; `Unhandled
  145. | _ -> `Unhandled
  146. in
  147. v $= menu_overlay h (f ())
  148. );
  149. `Handled
  150. | _ -> `Unhandled
  151. in
  152. Lwd_utils.pack Ui.pack_y [
  153. Lwd.return (Ui.mouse_area on_click text);
  154. Lwd.join (Lwd.get v)
  155. ]
  156. let sub_menu_item text f =
  157. let text = string ~attr:attr_menu_sub text in
  158. let v = Lwd.var empty_lwd in
  159. let visible = ref false in
  160. let on_click ~x:_ ~y:_ = function
  161. | `Left ->
  162. visible := not !visible;
  163. if not !visible then (
  164. v $= Lwd.return Ui.empty
  165. ) else (
  166. let h ~x:_ ~y:_ = function
  167. | `Left ->
  168. visible := false; v $= Lwd.return Ui.empty; `Unhandled
  169. | _ -> `Unhandled
  170. in
  171. v $= menu_overlay h (f ())
  172. );
  173. `Handled
  174. | _ -> `Unhandled
  175. in
  176. Lwd_utils.pack Ui.pack_x [
  177. Lwd.return (Ui.mouse_area on_click text);
  178. Lwd.join (Lwd.get v)
  179. ]
  180. let sub_entry text f =
  181. let text = string ~attr:attr_menu_sub text in
  182. let on_click ~x:_ ~y:_ = function
  183. | `Left -> f (); `Handled
  184. | _ -> `Unhandled
  185. in
  186. Ui.mouse_area on_click text
  187. let v_pane left right =
  188. let w = ref 10 in
  189. let h = ref 10 in
  190. let split = ref 0.5 in
  191. let splitter = Lwd.var empty_lwd in
  192. let splitter_bg = Lwd.var Ui.empty in
  193. let left_pane = Lwd.var empty_lwd in
  194. let right_pane = Lwd.var empty_lwd in
  195. let node = Lwd_utils.pack Ui.pack_y [!$left_pane; !$splitter; !$right_pane] in
  196. let render () =
  197. let split = int_of_float (!split *. float !h) in
  198. let split = min (!h - 1) (max split 0) in
  199. left_pane $= Lwd.map' left
  200. (fun t -> Ui.resize ~w:!w ~h:split t);
  201. right_pane $= Lwd.map' right
  202. (fun t -> Ui.resize ~w:!w ~h:(!h - split - 1) t);
  203. splitter_bg $= Ui.atom (I.char A.(bg lightyellow) ' ' !w 1);
  204. in
  205. let action ~x:_ ~y:_ = function
  206. | `Left ->
  207. let y0 = int_of_float (!split *. float !h) in
  208. `Grab ((fun ~x:_ ~y ->
  209. let y0' = y0 + y in
  210. split := min 1.0 (max 0.0 (float y0' /. float !h));
  211. render ()
  212. ), (fun ~x:_ ~y:_ -> ()))
  213. | _ -> `Unhandled
  214. in
  215. splitter $= Lwd.map (Ui.mouse_area action) (Lwd.get splitter_bg);
  216. render ();
  217. let on_resize ~w:ew ~h:eh =
  218. if !w <> ew || !h <> eh then (
  219. w := ew; h := eh;
  220. render ()
  221. )
  222. in
  223. Lwd.map' node @@ fun t ->
  224. Ui.size_sensor on_resize (Ui.resize ~w:10 ~h:10 ~sw:1 ~sh:1 t)
  225. type pane_state =
  226. | Split of { pos: int; max: int }
  227. | Re_split of { pos: int; max: int; at: int }
  228. let h_pane l r =
  229. let state_var = Lwd.var (Split {pos = 5; max = 10}) in
  230. let render state (l, r) =
  231. let (Split {pos; max} | Re_split {pos; max; _}) = state in
  232. let l = Ui.resize ~w:0 ~h:0 ~sh:1 ~sw:pos l in
  233. let r = Ui.resize ~w:0 ~h:0 ~sh:1 ~sw:(max - pos) r in
  234. let splitter =
  235. Ui.resize ~bg:Notty.A.(bg lightyellow) ~w:1 ~h:0 ~sw:0 ~sh:1 Ui.empty
  236. in
  237. let splitter =
  238. Ui.mouse_area (fun ~x:_ ~y:_ -> function
  239. | `Left ->
  240. `Grab (
  241. (fun ~x ~y:_ ->
  242. match Lwd.peek state_var with
  243. | Split {pos; max} ->
  244. Lwd.set state_var (Re_split {pos; max; at = x})
  245. | Re_split {pos; max; at} ->
  246. if at <> x then
  247. Lwd.set state_var (Re_split {pos; max; at = x})
  248. ),
  249. (fun ~x:_ ~y:_ -> ())
  250. )
  251. | _ -> `Unhandled
  252. ) splitter
  253. in
  254. let ui = Ui.join_x l (Ui.join_x splitter r) in
  255. let ui = Ui.resize ~w:10 ~h:10 ~sw:1 ~sh:1 ui in
  256. let ui = match state with
  257. | Split _ -> ui
  258. | Re_split {at; _} ->
  259. Ui.transient_sensor (fun ~x ~y:_ ~w ~h:_ () ->
  260. Lwd.set state_var (Split {pos = (at - x); max = w})
  261. ) ui
  262. in
  263. ui
  264. in
  265. Lwd.map2 render (Lwd.get state_var) (Lwd.pair l r)
  266. (*type pane_state =
  267. | Static of { w : int; h : int; split : float }
  268. | Resizing of { w : int; h : int; split : float; x : int; y : int; }
  269. let pane_h (Static {h; _} | Resizing {h; _}) = h
  270. let pane_w (Static {w; _} | Resizing {w; _}) = w
  271. let pane_split (Static {split; _} | Resizing {split; _}) = split
  272. let h_pane l r =
  273. let state_var = Lwd.var (Static {w = 0; h = 0 ; split = 0.5}) in
  274. let render state (l, r) =
  275. let h = pane_h state in
  276. let split = int_of_float (pane_split state *. float (pane_w state)) in
  277. let l = Ui.resize ~w:split ~h l in
  278. let r = Ui.resize ~w:(pane_w state - split - 1) ~h r in
  279. let splitter = Ui.atom (Notty.I.char Notty.A.(bg lightyellow) ' ' 1 h) in
  280. let splitter =
  281. Ui.mouse_area (fun ~x:_ ~y:_ -> function
  282. | `Left ->
  283. `Grab (
  284. (fun ~x ~y:_ ->
  285. match Lwd.peek state_var with
  286. | Static {w; h; split} ->
  287. Lwd.set state_var (Resizing {x = min_int; y = min_int; w; h; split})
  288. | Resizing r ->
  289. if r.x > min_int then
  290. let split = float (x - r.x) /. float r.w in
  291. Lwd.set state_var (Resizing {r with split})
  292. ),
  293. (fun ~x:_ ~y:_ ->
  294. match Lwd.peek state_var with
  295. | Static _ -> ()
  296. | Resizing {w; h; split; _} ->
  297. Lwd.set state_var (Static {w; h; split})
  298. )
  299. )
  300. | _ -> `Unhandled
  301. ) splitter
  302. in
  303. let ui = Ui.join_x l (Ui.join_x splitter r) in
  304. let ui = Ui.resize ~w:10 ~h:10 ~sw:1 ~sh:1 ui in
  305. let ui = match state with
  306. | Static _ ->
  307. Ui.size_sensor (fun ~w ~h ->
  308. match Lwd.peek state_var with
  309. | Static r ->
  310. if r.w <> w || r.h <> h then
  311. Lwd.set state_var (Static {r with w; h})
  312. | Resizing _ -> ()
  313. ) ui
  314. | Resizing _ ->
  315. Ui.permanent_sensor (fun ~x ~y ~w ~h ->
  316. match Lwd.peek state_var with
  317. | Static _ -> ignore
  318. | Resizing r ->
  319. if r.x <> x || r.y <> y || r.w <> w || r.h <> h then
  320. Lwd.set state_var (Resizing {x; y; w; h; split = r.split});
  321. ignore
  322. ) ui
  323. in
  324. ui
  325. in
  326. Lwd.map2 render (Lwd.get state_var) (Lwd.pair l r)*)
  327. let sub' str p l =
  328. if p = 0 && l = String.length str
  329. then str
  330. else String.sub str p l
  331. let edit_field ?(focus=Focus.make()) state ~on_change ~on_submit =
  332. let update focus_h focus (text, pos) =
  333. let pos = min (max 0 pos) (String.length text) in
  334. let content =
  335. Ui.atom @@ I.hcat @@
  336. if Focus.has_focus focus then (
  337. let attr = A.(bg lightblue) in
  338. let len = String.length text in
  339. (if pos >= len
  340. then [I.string attr text]
  341. else [I.string attr (sub' text 0 pos)])
  342. @
  343. (if pos < String.length text then
  344. [I.string A.(bg lightred) (sub' text pos 1);
  345. I.string attr (sub' text (pos + 1) (len - pos - 1))]
  346. else [I.string A.(bg lightred) " "]);
  347. ) else
  348. [I.string A.(st underline) (if text = "" then " " else text)]
  349. in
  350. let handler = function
  351. | `ASCII 'U', [`Ctrl] -> on_change ("", 0); `Handled (* clear *)
  352. | `Escape, [] -> Focus.release focus_h; `Handled
  353. | `ASCII k, _ ->
  354. let text =
  355. if pos < String.length text then (
  356. String.sub text 0 pos ^ String.make 1 k ^
  357. String.sub text pos (String.length text - pos)
  358. ) else (
  359. text ^ String.make 1 k
  360. )
  361. in
  362. on_change (text, (pos + 1));
  363. `Handled
  364. | `Backspace, _ ->
  365. let text =
  366. if pos > 0 then (
  367. if pos < String.length text then (
  368. String.sub text 0 (pos - 1) ^
  369. String.sub text pos (String.length text - pos)
  370. ) else if String.length text > 0 then (
  371. String.sub text 0 (String.length text - 1)
  372. ) else text
  373. ) else text
  374. in
  375. let pos = max 0 (pos - 1) in
  376. on_change (text, pos);
  377. `Handled
  378. | `Enter, _ -> on_submit (text, pos); `Handled
  379. | `Arrow `Left, [] ->
  380. let pos = min (String.length text) pos in
  381. if pos > 0 then (
  382. on_change (text, pos - 1);
  383. `Handled
  384. )
  385. else `Unhandled
  386. | `Arrow `Right, [] ->
  387. let pos = pos + 1 in
  388. if pos <= String.length text
  389. then (on_change (text, pos); `Handled)
  390. else `Unhandled
  391. | _ -> `Unhandled
  392. in
  393. Ui.keyboard_area ~focus handler content
  394. in
  395. let node =
  396. Lwd.map2 (update focus) (Focus.status focus) state
  397. in
  398. let mouse_grab (text, pos) ~x ~y:_ = function
  399. | `Left ->
  400. if x <> pos then on_change (text, x);
  401. Nottui.Focus.request focus;
  402. `Handled
  403. | _ -> `Unhandled
  404. in
  405. Lwd.map2' state node @@ fun state content ->
  406. Ui.mouse_area (mouse_grab state) content
  407. (** Tab view, where exactly one element of [l] is shown at a time. *)
  408. let tabs (tabs: (string * (unit -> Ui.t Lwd.t)) list) : Ui.t Lwd.t =
  409. match tabs with
  410. | [] -> Lwd.return Ui.empty
  411. | _ ->
  412. let cur = Lwd.var 0 in
  413. Lwd.get cur >>= fun idx_sel ->
  414. let _, f = List.nth tabs idx_sel in
  415. let tab_bar =
  416. tabs
  417. |> List.mapi
  418. (fun i (s,_) ->
  419. let attr = if i = idx_sel then A.(st underline) else A.empty in
  420. let tab_annot = printf ~attr "[%s]" s in
  421. Ui.mouse_area
  422. (fun ~x:_ ~y:_ l -> if l=`Left then (Lwd.set cur i; `Handled) else `Unhandled)
  423. tab_annot)
  424. |> Ui.hcat
  425. in
  426. f() >|= Ui.join_y tab_bar
  427. (** Horizontal/vertical box. We fill lines until there is no room,
  428. and then go to the next ligne. All widgets in a line are considered to
  429. have the same height.
  430. @param width dynamic width (default 80)
  431. *)
  432. let flex_box ?(w=Lwd.return 80) (l: Ui.t Lwd.t list) : Ui.t Lwd.t =
  433. Lwd_utils.flatten_l l >>= fun l ->
  434. w >|= fun w_limit ->
  435. let rec box_render (acc:Ui.t) (i:int) l : Ui.t =
  436. match l with
  437. | [] -> acc
  438. | ui0 :: tl ->
  439. let w0 = (Ui.layout_spec ui0).Ui.w in
  440. if i + w0 >= w_limit then (
  441. (* newline starting with ui0 *)
  442. Ui.join_y acc (box_render ui0 w0 tl)
  443. ) else (
  444. (* same line *)
  445. box_render (Ui.join_x acc ui0) (i+w0) tl
  446. )
  447. in
  448. box_render Ui.empty 0 l
  449. (** Prints the summary, but calls [f()] to compute a sub-widget
  450. when clicked on. Useful for displaying deep trees. *)
  451. let unfoldable ?(folded_by_default=true) summary (f: unit -> Ui.t Lwd.t) : Ui.t Lwd.t =
  452. let open Lwd.Infix in
  453. let opened = Lwd.var (not folded_by_default) in
  454. let fold_content =
  455. Lwd.get opened >>= function
  456. | true ->
  457. (* call [f] and pad a bit *)
  458. f() |> Lwd.map (Ui.join_x (string " "))
  459. | false -> empty_lwd
  460. in
  461. (* pad summary with a "> " when it's opened *)
  462. let summary =
  463. Lwd.get opened >>= fun op ->
  464. summary >|= fun s ->
  465. Ui.hcat [string ~attr:A.(bg blue) (if op then "v" else ">"); string " "; s]
  466. in
  467. let cursor ~x:_ ~y:_ = function
  468. | `Left when Lwd.peek opened -> Lwd.set opened false; `Handled
  469. | `Left -> Lwd.set opened true; `Handled
  470. | _ -> `Unhandled
  471. in
  472. let mouse = Lwd.map (fun m -> Ui.mouse_area cursor m) summary in
  473. Lwd.map2
  474. (fun summary fold ->
  475. (* TODO: make this configurable/optional *)
  476. (* newline if it's too big to fit on one line nicely *)
  477. let spec_sum = Ui.layout_spec summary in
  478. let spec_fold = Ui.layout_spec fold in
  479. (* TODO: somehow, probe for available width here? *)
  480. let too_big =
  481. spec_fold.Ui.h > 1 ||
  482. (spec_fold.Ui.h>0 && spec_sum.Ui.w + spec_fold.Ui.w > 60)
  483. in
  484. if too_big
  485. then Ui.join_y summary (Ui.join_x (string " ") fold)
  486. else Ui.join_x summary fold)
  487. mouse fold_content
  488. let hbox l = Lwd_utils.pack Ui.pack_x l
  489. let vbox l = Lwd_utils.pack Ui.pack_y l
  490. let zbox l = Lwd_utils.pack Ui.pack_z l
  491. let vlist ?(bullet="- ") (l: Ui.t Lwd.t list) : Ui.t Lwd.t =
  492. l
  493. |> List.map (fun ui -> Lwd.map (Ui.join_x (string bullet)) ui)
  494. |> Lwd_utils.pack Ui.pack_y
  495. (** A list of items with a dynamic filter on the items *)
  496. let vlist_with
  497. ?(bullet="- ")
  498. ?(filter=Lwd.return (fun _ -> true))
  499. (f:'a -> Ui.t Lwd.t)
  500. (l:'a list Lwd.t) : Ui.t Lwd.t =
  501. let open Lwd.Infix in
  502. let rec filter_map_ acc f l =
  503. match l with
  504. | [] -> List.rev acc
  505. | x::l' ->
  506. let acc' = match f x with | None -> acc | Some y -> y::acc in
  507. filter_map_ acc' f l'
  508. in
  509. let l = l >|= List.map (fun x -> x, Lwd.map (Ui.join_x (string bullet)) @@ f x) in
  510. let l_filter : _ list Lwd.t =
  511. filter >>= fun filter ->
  512. l >|=
  513. filter_map_ []
  514. (fun (x,ui) -> if filter x then Some ui else None)
  515. in
  516. l_filter >>= Lwd_utils.pack Ui.pack_y
  517. let rec iterate n f x =
  518. if n=0 then x else iterate (n-1) f (f x)
  519. (** A grid layout, with alignment in all rows/columns.
  520. @param max_h maximum height of a cell
  521. @param max_w maximum width of a cell
  522. @param bg attribute for controlling background style
  523. @param h_space horizontal space between each cell in a row
  524. @param v_space vertical space between each row
  525. @param pad used to control padding of cells
  526. @param crop used to control cropping of cells
  527. TODO: control padding/alignment, vertically and horizontally
  528. TODO: control align left/right in cells
  529. TODO: horizontal rule below headers
  530. TODO: headers *)
  531. let grid
  532. ?max_h ?max_w
  533. ?pad ?crop ?bg
  534. ?(h_space=0)
  535. ?(v_space=0)
  536. ?(headers:Ui.t Lwd.t list option)
  537. (rows: Ui.t Lwd.t list list) : Ui.t Lwd.t =
  538. let rows = match headers with
  539. | None -> rows
  540. | Some r -> r :: rows
  541. in
  542. (* build a [ui list list Lwd.t] *)
  543. begin
  544. Lwd_utils.map_l (fun r -> Lwd_utils.flatten_l r) rows
  545. end >>= fun (rows:Ui.t list list) ->
  546. (* determine width of each column and height of each row *)
  547. let n_cols = List.fold_left (fun n r -> max n (List.length r)) 0 rows in
  548. let col_widths = Array.make n_cols 1 in
  549. List.iter
  550. (fun row ->
  551. List.iteri
  552. (fun col_j cell ->
  553. let w = (Ui.layout_spec cell).Ui.w in
  554. col_widths.(col_j) <- max col_widths.(col_j) w)
  555. row)
  556. rows;
  557. begin match max_w with
  558. | None -> ()
  559. | Some max_w ->
  560. (* limit width *)
  561. Array.iteri (fun i x -> col_widths.(i) <- min x max_w) col_widths
  562. end;
  563. (* now render, with some padding *)
  564. let pack_pad_x =
  565. if h_space<=0 then (Ui.empty, Ui.join_x)
  566. else (Ui.empty, (fun x y -> Ui.hcat [x; Ui.space h_space 0; y]))
  567. and pack_pad_y =
  568. if v_space =0 then (Ui.empty, Ui.join_y)
  569. else (Ui.empty, (fun x y -> Ui.vcat [x; Ui.space v_space 0; y]))
  570. in
  571. let rows =
  572. List.map
  573. (fun row ->
  574. let row_h =
  575. List.fold_left (fun n c -> max n (Ui.layout_spec c).Ui.h) 0 row
  576. in
  577. let row_h = match max_h with
  578. | None -> row_h
  579. | Some max_h -> min row_h max_h
  580. in
  581. let row =
  582. List.mapi
  583. (fun i c ->
  584. Ui.resize ~w:col_widths.(i) ~h:row_h ?crop ?pad ?bg c)
  585. row
  586. in
  587. Lwd_utils.reduce pack_pad_x row)
  588. rows
  589. in
  590. (* TODO: mouse and keyboard handling *)
  591. let ui = Lwd_utils.reduce pack_pad_y rows in
  592. Lwd.return ui
  593. let button ?attr s f =
  594. Ui.mouse_area (fun ~x:_ ~y:_ _ -> f(); `Handled) (string ?attr s)
  595. (* file explorer for selecting a file *)
  596. let file_select
  597. ?(abs=false)
  598. ?filter
  599. ~(on_select:string -> unit) () : Ui.t Lwd.t =
  600. let rec aux ~fold path =
  601. try
  602. let p_rel = if path = "" then "." else path in
  603. if Sys.is_directory p_rel then (
  604. let ui() =
  605. let arr = Sys.readdir p_rel in
  606. let l = Array.to_list arr |> List.map (Filename.concat path) in
  607. (* apply potential filter *)
  608. let l = match filter with None -> l | Some f -> List.filter f l in
  609. let l = Lwd.return @@ List.sort String.compare l in
  610. vlist_with ~bullet:"" (aux ~fold:true) l
  611. in
  612. if fold then (
  613. unfoldable ~folded_by_default:true
  614. (Lwd.return @@ string @@ path ^ "/") ui
  615. ) else ui ()
  616. ) else (
  617. Lwd.return @@
  618. button ~attr:A.(st underline) path (fun () -> on_select path)
  619. )
  620. with e ->
  621. Lwd.return @@ Ui.vcat [
  622. printf ~attr:A.(bg red) "cannot list directory %s" path;
  623. string @@ Printexc.to_string e;
  624. ]
  625. in
  626. let start = if abs then Sys.getcwd () else "" in
  627. aux ~fold:false start
  628. let toggle, toggle' =
  629. let toggle_ st (lbl:string Lwd.t) (f:bool -> unit) : Ui.t Lwd.t =
  630. let mk_but st_v lbl_v =
  631. let lbl = Printf.sprintf "[%s|%s]" lbl_v (if st_v then "✔" else "×");in
  632. button lbl (fun () ->
  633. let new_st = not st_v in
  634. Lwd.set st new_st; f new_st)
  635. in
  636. Lwd.map2 mk_but (Lwd.get st) lbl
  637. in
  638. (* Similar to {!toggle}, except it directly reflects the state of a variable. *)
  639. let toggle' (lbl:string Lwd.t) (v:bool Lwd.var) : Ui.t Lwd.t =
  640. toggle_ v lbl (Lwd.set v)
  641. (* a toggle, with a true/false state *)
  642. and toggle ?(init=false) (lbl:string Lwd.t) (f:bool -> unit) : Ui.t Lwd.t =
  643. let st = Lwd.var init in
  644. toggle_ st lbl f
  645. in
  646. toggle, toggle'