3374 lines
105 KiB
OCaml
3374 lines
105 KiB
OCaml
(* why *)
|
||
|
||
(*
|
||
|
||
names?:
|
||
- universal tool, unitool [was thinking about how this is trying to unify a lot of my "tools for thought"]
|
||
* because it has always bothered me that it's easier to use google search as a calculator than the purpose built app!!!!!!!!
|
||
- universal console, unicon (UNICOrN) [unicon is nice ;3]
|
||
- non-magical systems (NMS) un-magical
|
||
- console is an interface to allow you to program your computer more easily.
|
||
|
||
describe exactly every case you can think of that you want this drawing and layout system to handle:
|
||
|
||
* draw text on variously coloured backgrounds that can be defined locally or globally
|
||
* TODO
|
||
|
||
*)
|
||
|
||
(*
|
||
|
||
ALWAYS BREAK UP THE PROBLEM INTO SMALLER CHUNKS BITCH!!
|
||
|
||
Times I would have solved it faster if i broke it up instead of trying to understand it all at once: 2
|
||
|
||
a computation console
|
||
|
||
- irmin store provides a tree of data objects
|
||
- the tree can be navigated in the default view
|
||
- the selected object can be edited <enter> or executed as an ocaml top level phrase <C-enter>
|
||
- each execution stores any edited modifications and the command to execute that phrase in the current irmin store context as a commit message
|
||
- while editing a data object <ctrl-enter> wille search for the previous and next `;;` or BOF/EOF and execute the enclosed text and the commit message includes the character offsets of the executed text.
|
||
- executions can modify the window system creating new windows and redirecting input focus. They define their own input handling however C-g,C-g,C-g will restore the window system to the default??
|
||
|
||
but how do we integrate this with the ocaml environment and name spaces??
|
||
some options:
|
||
- always wrap execution units from data objects in some sort of local namespace so opens are not global?
|
||
- dig into the toplevel environment and manipulate it, this will also help with things like completion and context help
|
||
|
||
*)
|
||
open Js_of_ocaml
|
||
module F = Fmt
|
||
|
||
module Logs_reporter = struct
|
||
(* Console reporter *)
|
||
|
||
open Jsoo_runtime
|
||
|
||
let console : Logs.level -> string -> unit =
|
||
fun level s ->
|
||
let meth =
|
||
match level with
|
||
| Logs.Error -> "error"
|
||
| Logs.Warning -> "warn"
|
||
| Logs.Info -> "info"
|
||
| Logs.Debug -> "debug"
|
||
| Logs.App -> "log"
|
||
in
|
||
ignore
|
||
(Js.meth_call
|
||
(Js.pure_js_expr "console")
|
||
meth
|
||
[| Js.string s |])
|
||
|
||
let ppf, flush =
|
||
let b = Buffer.create 255 in
|
||
let flush () =
|
||
let s = Buffer.contents b in
|
||
Buffer.clear b;
|
||
s
|
||
in
|
||
(Format.formatter_of_buffer b, flush)
|
||
|
||
let hook =
|
||
ref (fun level s ->
|
||
ignore (Logs.level_to_string (Some level) ^ ": " ^ s))
|
||
|
||
let console_report _src level ~over k msgf =
|
||
let k _ =
|
||
let s = flush () in
|
||
console level s;
|
||
!hook level s;
|
||
over ();
|
||
k ()
|
||
in
|
||
msgf @@ fun ?header ?tags fmt ->
|
||
let _tags = tags in
|
||
match header with
|
||
| None -> Format.kfprintf k ppf ("@[" ^^ fmt ^^ "@]@.")
|
||
| Some h -> Format.kfprintf k ppf ("[%s] @[" ^^ fmt ^^ "@]@.") h
|
||
|
||
let console_reporter () = { Logs.report = console_report }
|
||
end
|
||
|
||
let _ =
|
||
Logs.set_reporter (Logs_reporter.console_reporter ());
|
||
Logs.set_level (Some Debug)
|
||
|
||
module Log = Logs
|
||
module Cohttp_backend = Cohttp_lwt_jsoo
|
||
|
||
module Git_af = struct
|
||
open Lwt.Infix
|
||
|
||
type error = |
|
||
|
||
let git_af_scheme : [ `HTTP | `HTTPS ] Mimic.value =
|
||
Mimic.make ~name:"git-af-scheme"
|
||
|
||
let git_af_port : int Mimic.value = Mimic.make ~name:"git-af-port"
|
||
|
||
let git_af_hostname : string Mimic.value =
|
||
Mimic.make ~name:"git-af-hostname"
|
||
|
||
let pp_error : error Fmt.t = fun _ppf -> function _ -> .
|
||
|
||
let with_redirects ?(max = 10) ~f uri =
|
||
if max < 10 then invalid_arg "with_redirects";
|
||
let tbl = Hashtbl.create 0x10 in
|
||
let rec go max uri =
|
||
f uri >>= fun (resp, body) ->
|
||
let status_code =
|
||
Cohttp.(Response.status resp |> Code.code_of_status)
|
||
in
|
||
if Cohttp.Code.is_redirection status_code then
|
||
match
|
||
Cohttp.(Response.headers resp |> Header.get_location)
|
||
with
|
||
| Some uri' when Hashtbl.mem tbl uri' || max = 0 ->
|
||
Lwt.return (resp, body)
|
||
| Some uri' ->
|
||
Hashtbl.add tbl uri' ();
|
||
Cohttp_lwt.Body.drain_body body >>= fun () ->
|
||
go (pred max) uri'
|
||
| None -> Lwt.return (resp, body)
|
||
else Lwt.return (resp, body)
|
||
in
|
||
go max uri
|
||
|
||
let get ~ctx:_ ?(headers = []) uri =
|
||
Firebug.console##log (Js.string "Git_Cohttp_console.get()\n");
|
||
let headers = Cohttp.Header.of_list headers in
|
||
let f uri = Cohttp_backend.Client.get ~headers uri in
|
||
with_redirects ~f uri >>= fun (_resp, body) ->
|
||
Cohttp_lwt.Body.to_string body >>= fun body ->
|
||
Lwt.return_ok ((), body)
|
||
|
||
let post ~ctx:_ ?(headers = []) uri body =
|
||
let headers = Cohttp.Header.of_list headers in
|
||
let body = Cohttp_lwt.Body.of_string body in
|
||
let f uri =
|
||
Cohttp_backend.Client.post ~headers ~chunked:false ~body uri
|
||
in
|
||
with_redirects ~f uri >>= fun (_resp, body) ->
|
||
Cohttp_lwt.Body.to_string body >>= fun body ->
|
||
Lwt.return_ok ((), body)
|
||
end
|
||
|
||
module Git_console_http = struct
|
||
open Lwt.Infix
|
||
|
||
let context ctx =
|
||
(* HTTP *)
|
||
let edn = Mimic.make ~name:"af-http-endpoint" in
|
||
let k1 git_af_scheme git_af_hostname git_af_port =
|
||
match git_af_scheme with
|
||
| `HTTP -> Lwt.return_some (git_af_hostname, git_af_port)
|
||
| _ -> Lwt.return_none
|
||
in
|
||
let ctx =
|
||
Mimic.fold edn
|
||
Mimic.Fun.
|
||
[
|
||
req Git_af.git_af_scheme;
|
||
req Git_af.git_af_hostname;
|
||
dft Git_af.git_af_port 80;
|
||
]
|
||
~k:k1 ctx
|
||
in
|
||
|
||
(* HTTPS *)
|
||
let edn = Mimic.make ~name:"af-https-endpoint" in
|
||
let k1 git_af_scheme git_af_hostname git_af_port =
|
||
match git_af_scheme with
|
||
| `HTTPS -> Lwt.return_some (git_af_hostname, git_af_port)
|
||
| _ -> Lwt.return_none
|
||
in
|
||
|
||
let ctx =
|
||
Mimic.fold edn
|
||
Mimic.Fun.
|
||
[
|
||
req Git_af.git_af_scheme;
|
||
req Git_af.git_af_hostname;
|
||
dft Git_af.git_af_port 443;
|
||
]
|
||
~k:k1 ctx
|
||
in
|
||
|
||
ctx
|
||
|
||
module HTTP = struct
|
||
type state =
|
||
| Handshake
|
||
| Get of {
|
||
advertised_refs : string;
|
||
uri : Uri.t;
|
||
headers : (string * string) list;
|
||
ctx : Mimic.ctx;
|
||
}
|
||
| Post of {
|
||
mutable output : string;
|
||
uri : Uri.t;
|
||
headers : (string * string) list;
|
||
ctx : Mimic.ctx;
|
||
}
|
||
| Error
|
||
|
||
type flow = { endpoint : Uri.t; mutable state : state }
|
||
type error = [ `Msg of string ]
|
||
type write_error = [ `Closed | `Msg of string ]
|
||
|
||
let pp_error ppf (`Msg err) = Fmt.string ppf err
|
||
|
||
let pp_write_error ppf = function
|
||
| `Closed -> Fmt.string ppf "Connection closed by peer"
|
||
| `Msg err -> Fmt.string ppf err
|
||
|
||
let write t cs =
|
||
match t.state with
|
||
| Handshake | Get _ ->
|
||
Lwt.return_error (`Msg "Handshake has not been done")
|
||
| Error -> Lwt.return_error (`Msg "Handshake got an error")
|
||
| Post ({ output; _ } as v) ->
|
||
let output = output ^ Cstruct.to_string cs in
|
||
v.output <- output;
|
||
Lwt.return_ok ()
|
||
|
||
let writev t css =
|
||
let rec go = function
|
||
| [] -> Lwt.return_ok ()
|
||
| x :: r -> (
|
||
write t x >>= function
|
||
| Ok () -> go r
|
||
| Error _ as err -> Lwt.return err)
|
||
in
|
||
go css
|
||
|
||
let read t =
|
||
match t.state with
|
||
| Handshake ->
|
||
Lwt.return_error (`Msg "Handshake has not been done")
|
||
| Error -> Lwt.return_error (`Msg "Handshake got an error")
|
||
| Get { advertised_refs; uri; headers; ctx } ->
|
||
t.state <- Post { output = ""; uri; headers; ctx };
|
||
Lwt.return_ok (`Data (Cstruct.of_string advertised_refs))
|
||
| Post { output; uri; headers; ctx } -> (
|
||
Git_af.post ~ctx ~headers uri output >>= function
|
||
| Ok (_resp, contents) ->
|
||
Lwt.return_ok (`Data (Cstruct.of_string contents))
|
||
| Error err ->
|
||
Lwt.return_error (`Msg (Fmt.str "%a" pp_error err)))
|
||
|
||
let close _ = Lwt.return_unit
|
||
|
||
type endpoint = Uri.t
|
||
|
||
let connect endpoint =
|
||
Firebug.console##log
|
||
(Js.string "Git_Console_http.HTTP.connect()\n");
|
||
Lwt.return_ok { endpoint; state = Handshake }
|
||
end
|
||
|
||
let http_endpoint, http_protocol =
|
||
Mimic.register ~name:"http" (module HTTP)
|
||
|
||
let connect (ctx : Mimic.ctx) =
|
||
Firebug.console##log (Js.string "Git_Console_http.connect()\n");
|
||
let module T = (val Mimic.repr http_protocol) in
|
||
let edn = Mimic.make ~name:"http-endpoint" in
|
||
let k0 uri = Lwt.return_some uri in
|
||
let k1 git_transmission git_scheme =
|
||
match (git_transmission, git_scheme) with
|
||
| `HTTP (uri, _), (`HTTP | `HTTPS) -> Lwt.return_some uri
|
||
| _ -> Lwt.return_none
|
||
in
|
||
let k2 git_scheme git_uri git_http_headers =
|
||
match git_scheme with
|
||
| `Git | `SSH | `Scheme _ -> Lwt.return_none
|
||
| `HTTP | `HTTPS ->
|
||
let headers =
|
||
("content-type", "application/x-git-upload-pack-request")
|
||
:: git_http_headers
|
||
in
|
||
let handshake ~uri0 ~uri1 = function
|
||
| T.T flow -> (
|
||
Firebug.console##log
|
||
(Js.string
|
||
(F.str
|
||
"Git_Console_http.connect.k2.handshake \
|
||
uri0='%s' uri1='%s'\n"
|
||
(Uri.to_string uri0) (Uri.to_string uri1)));
|
||
let ctx = context Mimic.empty in
|
||
Git_af.get ~ctx ~headers uri0 >>= function
|
||
| Ok (_resp, advertised_refs) ->
|
||
flow.state <-
|
||
HTTP.Get
|
||
{ advertised_refs; uri = uri1; headers; ctx };
|
||
Lwt.return_unit
|
||
| Error _ ->
|
||
flow.state <- Error;
|
||
Lwt.return_unit)
|
||
| _ -> Lwt.return_unit
|
||
in
|
||
let git_transmission = `HTTP (git_uri, handshake) in
|
||
Lwt.return_some git_transmission
|
||
in
|
||
let ctx =
|
||
Mimic.fold http_endpoint Mimic.Fun.[ req edn ] ~k:k0 ctx
|
||
in
|
||
let ctx =
|
||
Mimic.fold edn
|
||
Mimic.Fun.
|
||
[ req Smart_git.git_transmission; req Smart_git.git_scheme ]
|
||
~k:k1 ctx
|
||
in
|
||
let ctx =
|
||
Mimic.fold Smart_git.git_transmission
|
||
Mimic.Fun.
|
||
[
|
||
req Smart_git.git_scheme;
|
||
req Smart_git.git_uri;
|
||
dft Smart_git.git_http_headers List.[];
|
||
]
|
||
~k:k2 ctx
|
||
in
|
||
Lwt.return ctx
|
||
end
|
||
|
||
module Nav = struct
|
||
open Lwt.Infix
|
||
|
||
module Config = struct
|
||
open Irmin.Backend.Conf
|
||
|
||
let spec = Spec.v "console_js_git"
|
||
|
||
module Key = struct
|
||
let reference : Git.Reference.t Irmin.Type.t =
|
||
let of_string str =
|
||
Git.Reference.of_string str |> Result.get_ok
|
||
in
|
||
let to_string r = Git.Reference.to_string r in
|
||
Irmin.Type.(map string) of_string to_string
|
||
|
||
let head =
|
||
key ~spec ~doc:"The main branch of the Git repository." "head"
|
||
Irmin.Type.(option reference)
|
||
None
|
||
|
||
let bare =
|
||
key ~spec ~doc:"Do not expand the filesystem on the disk."
|
||
"bare" Irmin.Type.bool false
|
||
|
||
let level =
|
||
key ~spec ~doc:"The Zlib compression level." "level"
|
||
Irmin.Type.(option int)
|
||
None
|
||
|
||
let buffers =
|
||
key ~spec ~doc:"The number of 4K pre-allocated buffers."
|
||
"buffers"
|
||
Irmin.Type.(option int)
|
||
None
|
||
end
|
||
|
||
let init ?head ?level ?buffers _root =
|
||
let module C = Irmin.Backend.Conf in
|
||
let config = C.empty spec in
|
||
|
||
let config = C.add config Key.head head in
|
||
let config = C.add config Key.level level in
|
||
let config = C.add config Key.buffers buffers in
|
||
C.verify config
|
||
end
|
||
|
||
module S = struct
|
||
module Schema =
|
||
Irmin_git.Schema.Make (Git.Mem.Store) (Irmin.Contents.String)
|
||
(Irmin_git.Branch.Make (Irmin.Branch.String))
|
||
|
||
module Sync' = struct
|
||
module GitMemSync = Git.Mem.Sync (Git.Mem.Store)
|
||
include GitMemSync
|
||
(* This is where the fetch and push are broken *)
|
||
end
|
||
|
||
module SMaker = Irmin_git.Maker (Git.Mem.Store) (Sync')
|
||
module SMade = SMaker.Make (Schema)
|
||
include SMade
|
||
|
||
type endpoint = Mimic.ctx * Smart_git.Endpoint.t
|
||
|
||
let remote ?(ctx = Mimic.empty) ?headers uri =
|
||
E
|
||
(Firebug.console##log (Js.string "Nav.S.remote()\n");
|
||
let ( ! ) f a b = f b a in
|
||
match Smart_git.Endpoint.of_string uri with
|
||
| Ok edn ->
|
||
let edn =
|
||
Option.fold ~none:edn
|
||
~some:(!Smart_git.Endpoint.with_headers_if_http edn)
|
||
headers
|
||
in
|
||
Firebug.console##log
|
||
(Js.string "Nav.S.remote() = (ctx, edn) \n");
|
||
(ctx, edn)
|
||
| Error (`Msg err) -> Fmt.invalid_arg "remote: %s" err)
|
||
|
||
module Backend = struct
|
||
include Backend
|
||
module R = Remote
|
||
|
||
module Remote = struct
|
||
include R
|
||
|
||
type endpoint = Mimic.ctx * Smart_git.Endpoint.t
|
||
|
||
let ctx e = fst e
|
||
let edn e = snd e
|
||
|
||
let fetch t ?depth endpoint branch =
|
||
Firebug.console##log
|
||
(Js.string "S.Backend.Remote.wrapped_fetch()\n");
|
||
R.fetch t ?depth endpoint branch
|
||
end
|
||
end
|
||
end
|
||
|
||
module Sync = Irmin.Sync.Make (S)
|
||
|
||
type t = S.tree
|
||
type tree = t
|
||
type step = S.step
|
||
type path = step list
|
||
|
||
let init () = S.Repo.v (Irmin_mem.config ()) >>= S.main >>= S.tree
|
||
|
||
let test_populate () : t Lwt.t =
|
||
let add p s t = S.Tree.add t p s in
|
||
add [ "hello" ] "world" (S.Tree.empty ())
|
||
>>= add [ "hello"; "daddy" ] "ily"
|
||
>>= add [ "beep"; "beep" ] "motherfucker"
|
||
|
||
let test_pull () : t Lwt.t =
|
||
(* test_populate ()*)
|
||
Firebug.console##log (Js.string "Nav.test_pull()\n");
|
||
S.Repo.v (Config.init "") >>= fun repo ->
|
||
Firebug.console##log (Js.string "Nav.test_pull(2)\n");
|
||
S.of_branch repo "current" >>= fun t ->
|
||
Firebug.console##log (Js.string "Nav.test_pull(3)\n");
|
||
Git_console_http.connect Mimic.empty >>= fun ctx ->
|
||
Firebug.console##log (Js.string "Nav.test_pull(4)\n");
|
||
let upstream =
|
||
S.remote ~ctx "https://localhost:8080/console/rootstore.git"
|
||
in
|
||
Firebug.console##log (Js.string "Nav.test_pull(5)\n");
|
||
Sync.fetch_exn t upstream >>= fun _ -> S.tree t
|
||
(* irmin/src/irmin/sync.ml: calls S.Remote.Backend.fetch *)
|
||
end
|
||
|
||
module Input = struct
|
||
type button =
|
||
[ `Left | `Middle | `Right | `Scroll of [ `Up | `Down ] ]
|
||
|
||
type special =
|
||
[ `Enter
|
||
| `Escape
|
||
| `Tab
|
||
| `Arrow of [ `Up | `Down | `Left | `Right ]
|
||
| `Function of int
|
||
| `Page of [ `Up | `Down ]
|
||
| `Home
|
||
| `End
|
||
| `Insert
|
||
| `Delete
|
||
| `Backspace
|
||
| `Unknown of string ]
|
||
|
||
(* Type of key code. *)
|
||
type code =
|
||
[ `Uchar of Uchar.t (* A unicode character. *) | special ]
|
||
|
||
(* stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *)
|
||
let string_of_code = function
|
||
| `Uchar ch ->
|
||
if Uchar.is_char ch then F.str "Char '%c'" (Uchar.to_char ch)
|
||
else F.str "Char 0x%02x" (Uchar.to_int ch)
|
||
| `Enter -> "Enter"
|
||
| `Escape -> "Escape"
|
||
| `Tab -> "Tab"
|
||
| `Arrow `Up -> "Up"
|
||
| `Arrow `Down -> "Down"
|
||
| `Arrow `Left -> "Left"
|
||
| `Arrow `Right -> "Right"
|
||
| `Function i -> F.str "F%d" i
|
||
| `Page `Up -> "Page Up"
|
||
| `Page `Down -> "Page Down"
|
||
| `Home -> "Home"
|
||
| `End -> "End"
|
||
| `Insert -> "Insert"
|
||
| `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 ~sep:F.sp (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
|
||
open Js_of_ocaml
|
||
|
||
let evt_of_jskey (evt : Dom_html.keyboardEvent Js.t) =
|
||
( (match Js.Optdef.to_option evt##.key with
|
||
| Some s -> (
|
||
match Js.to_string s with
|
||
| "Enter" -> `Enter
|
||
| "Escape" -> `Escape
|
||
| "Tab" -> `Tab
|
||
| "ArrowUp" -> `Arrow `Up
|
||
| "ArrowDown" -> `Arrow `Down
|
||
| "ArrowLeft" -> `Arrow `Left
|
||
| "ArrowRight" -> `Arrow `Right
|
||
| "PageUp" -> `Page `Up
|
||
| "PageDown" -> `Page `Down
|
||
| "Home" -> `Home
|
||
| "End" -> `End
|
||
| "Insert" -> `Insert
|
||
| "Delete" -> `Delete
|
||
| "Backspace" -> `Backspace
|
||
| s -> (
|
||
match Dom_html.Keyboard_key.of_event evt with
|
||
| Some s' -> `Uchar s'
|
||
| None -> `Unknown s))
|
||
| None -> `Unknown "keypress .key is None?"),
|
||
(if Js.to_bool evt##.altKey then [ `Meta ] else [])
|
||
@ (if Js.to_bool evt##.shiftKey then [ `Shift ] else [])
|
||
@ (if Js.to_bool evt##.ctrlKey then [ `Ctrl ] else [])
|
||
@ if Js.to_bool evt##.metaKey then [ `Super ] else [] )
|
||
end
|
||
|
||
open Gg
|
||
|
||
module NVG = struct
|
||
include Graphv_webgl
|
||
|
||
module Color = struct
|
||
include Graphv_webgl.Color
|
||
|
||
let none = Color.transparent
|
||
let rgbf = Color.rgbf
|
||
let gray a = rgbf ~r:a ~g:a ~b:a
|
||
let light = gray 0.8
|
||
let dark = gray 0.2
|
||
|
||
let black = gray 0.
|
||
and red = rgbf ~r:1. ~g:0. ~b:0.
|
||
and green = rgbf ~r:0. ~g:1. ~b:0.
|
||
and yellow = rgbf ~r:1. ~g:1. ~b:0.
|
||
and blue = rgbf ~r:0. ~g:0. ~b:1.
|
||
and magenta = rgbf ~r:1. ~g:0. ~b:1.
|
||
and cyan = rgbf ~r:0. ~g:1. ~b:1.
|
||
and white = rgbf ~r:1. ~g:1. ~b:1.
|
||
and lightblack = gray 0.5
|
||
and lightred = rgbf ~r:1.0 ~g:0.5 ~b:0.5
|
||
and lightgreen = rgbf ~r:0.5 ~g:1.0 ~b:0.5
|
||
and lightyellow = rgbf ~r:1.0 ~g:1.0 ~b:0.5
|
||
and lightblue = rgbf ~r:0.5 ~g:0.5 ~b:1.0
|
||
and lightmagenta = rgbf ~r:1.0 ~g:0.5 ~b:1.0
|
||
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);
|
||
}
|
||
|
||
let replace ~prev ~next = if next = none then prev else next
|
||
|
||
let pp ppf t : unit =
|
||
if t != none then
|
||
F.(
|
||
fmt "%a" ppf
|
||
(list (fmt "%02X"))
|
||
(List.map
|
||
(fun e -> int_of_float (e *. 255.))
|
||
[ t.r; t.g; t.b; t.a ]))
|
||
else F.fmt "_" ppf
|
||
end
|
||
end
|
||
|
||
module Color = NVG.Color
|
||
|
||
(* from notty.ml *)
|
||
let btw (x : int) a b = a <= x && x <= b
|
||
|
||
module Buffer = struct
|
||
include Stdlib.Buffer
|
||
|
||
let buf = create 1024
|
||
|
||
let mkstring f =
|
||
f buf;
|
||
let res = contents buf in
|
||
reset buf;
|
||
res
|
||
|
||
let add_decimal b = function
|
||
| x when btw x 0 999 ->
|
||
let d1 = x / 100 and d2 = x mod 100 / 10 and d3 = x mod 10 in
|
||
if d1 > 0 then 0x30 + d1 |> Char.unsafe_chr |> add_char b;
|
||
if d1 + d2 > 0 then 0x30 + d2 |> Char.unsafe_chr |> add_char b;
|
||
0x30 + d3 |> Char.unsafe_chr |> add_char b
|
||
| x -> string_of_int x |> add_string b
|
||
|
||
let add_chars b c n =
|
||
for _ = 1 to n do
|
||
add_char b c
|
||
done
|
||
end
|
||
|
||
module String = struct
|
||
include String
|
||
|
||
let sub0cp s i len =
|
||
if i > 0 || len < length s then sub s i len else s
|
||
|
||
let of_chars_rev = function
|
||
| [] -> ""
|
||
| [ c ] -> String.make 1 c
|
||
| cs ->
|
||
let n = List.length cs in
|
||
let rec go bs i =
|
||
Bytes.(
|
||
function
|
||
| [] -> unsafe_to_string bs
|
||
| x :: xs ->
|
||
unsafe_set bs i x;
|
||
go bs (pred i) xs)
|
||
in
|
||
go (Bytes.create n) (n - 1) cs
|
||
end
|
||
|
||
module Text = struct
|
||
include NVG.Text
|
||
|
||
type t = String of string (* | Uchars of Uchar.t list*)
|
||
|
||
let empty = String ""
|
||
|
||
let equal = function
|
||
| String a -> ( function String b -> String.equal a b)
|
||
|
||
let of_string s = String s
|
||
let to_string = function String s -> s
|
||
|
||
let of_uchars ucs =
|
||
of_string @@ Buffer.mkstring
|
||
@@ fun buf -> Array.iter (Buffer.add_utf_8_uchar buf) ucs
|
||
|
||
let replicatec w c = String (String.make (int_of_float w) c)
|
||
|
||
let pp ppf : t -> unit = function
|
||
| String s -> F.(fmt "\"%s\"" ppf s)
|
||
end
|
||
|
||
module Style = struct
|
||
module Font = struct
|
||
type t = {
|
||
size : float option;
|
||
font : [ `Sans | `Serif | `Mono | `None ];
|
||
weight : [ `Bold | `Regular | `Light | `None ];
|
||
italic : [ `Italic | `None ];
|
||
underline : [ `Underline | `None ];
|
||
}
|
||
|
||
let pp ppf =
|
||
F.(
|
||
fmt "%a" ppf
|
||
(record [ field "size" (fun a -> a.size) (option float) ]))
|
||
|
||
let empty =
|
||
{
|
||
size = None;
|
||
font = `None;
|
||
weight = `None;
|
||
italic = `None;
|
||
underline = `None;
|
||
}
|
||
|
||
let underline = { empty with underline = `Underline }
|
||
let size { size; _ } = match size with None -> 20. | Some s -> s
|
||
|
||
let merge a b =
|
||
{
|
||
size =
|
||
(match (a.size, b.size) with
|
||
| None, None -> None
|
||
| Some s, None | None, Some s -> Some s
|
||
| Some s1, Some s2 -> Some (Float.max_num s1 s2));
|
||
font =
|
||
(match (a.font, b.font) with
|
||
| `Sans, _ | _, `Sans -> `Sans
|
||
| `Serif, (`Serif | `Mono | `None) | (`Mono | `None), `Serif
|
||
->
|
||
`Serif
|
||
| `Mono, (`Mono | `None) | `None, `Mono -> `Mono
|
||
| `None, `None -> `None);
|
||
weight =
|
||
(match (a.weight, b.weight) with
|
||
| `Bold, _ | _, `Bold -> `Bold
|
||
| `Regular, (`Regular | `Light | `None)
|
||
| (`Light | `None), `Regular ->
|
||
`Regular
|
||
| `Light, (`Light | `None) | `None, `Light -> `Light
|
||
| `None, `None -> `None);
|
||
italic =
|
||
(match (a.italic, b.italic) with
|
||
| `Italic, _ | _, `Italic -> `Italic
|
||
| _ -> `None);
|
||
underline =
|
||
(match (a.underline, b.underline) with
|
||
| `Underline, _ | _, `Underline -> `Underline
|
||
| _ -> `None);
|
||
}
|
||
|
||
let set vg t =
|
||
(match t.size with
|
||
| Some size -> Text.set_size vg ~size
|
||
| None -> ());
|
||
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 }
|
||
type attr = t
|
||
|
||
let pp ppf a =
|
||
F.(fmt "@[<h>%a/%a@]" ppf Color.pp a.fg Color.pp a.bg)
|
||
|
||
let equal = ( == )
|
||
|
||
let empty =
|
||
{
|
||
fg = Color.transparent;
|
||
bg = Color.transparent;
|
||
font = Font.empty;
|
||
}
|
||
|
||
let dark = { empty with fg = Color.light; bg = Color.dark }
|
||
|
||
let ( ++ ) a1 a2 =
|
||
{
|
||
fg = Color.(a1.fg ++ a2.fg);
|
||
bg = Color.(a1.bg ++ a2.bg);
|
||
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 }
|
||
|
||
let merge a b =
|
||
{
|
||
fg = Color.lerp a.fg b.fg ~a:0.5;
|
||
bg = Color.lerp a.bg b.bg ~a:0.5;
|
||
font = Font.merge a.font b.font;
|
||
}
|
||
|
||
let set vg s =
|
||
F.epr "Style.set @.";
|
||
NVG.set_fill_color vg ~color:s.bg;
|
||
NVG.set_stroke_color vg ~color:s.fg;
|
||
Font.set vg s.font
|
||
|
||
let menu_main = bg Color.green ++ fg Color.black
|
||
let menu_sub = bg Color.lightgreen ++ fg Color.black
|
||
|
||
let clickable =
|
||
(bg @@ Color.rgbf ~r:0.2 ~g:0.2 ~b:0.5) ++ (fg @@ Color.light)
|
||
|
||
let cursor = (fg @@ Color.dark) ++ (bg @@ Color.yellow)
|
||
end
|
||
|
||
module Pad = struct
|
||
open Gg
|
||
|
||
type t = { t : size1; b : size1; l : size1; r : size1 }
|
||
|
||
let empty =
|
||
{ t = Size1.zero; b = Size1.zero; l = Size1.zero; r = Size1.zero }
|
||
|
||
let all v = { t = v; b = v; l = v; r = v }
|
||
end
|
||
|
||
module A = Style
|
||
|
||
module I = struct
|
||
open Gg
|
||
|
||
type dim = p2
|
||
|
||
type t =
|
||
| Empty
|
||
| Segment of Text.t (* box2 is +crop/-pad of drawn Text.t *)
|
||
| Attr of (t * A.t)
|
||
| Hcompose of (t * t)
|
||
| Vcompose of (t * t)
|
||
| Zcompose of (t * t)
|
||
| Hcrop of (t * float * float)
|
||
| Vcrop of (t * float * float)
|
||
| Void of dim
|
||
|
||
let p2_max p1 p2 : p2 =
|
||
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.Text.{ box = { ymax; ymin; _ }; advance } =
|
||
bounds_segment vg p s
|
||
in
|
||
V2.v advance (ymax -. ymin)
|
||
| Attr (t, _a) -> size vg p t
|
||
| Hcompose (t1, t2) ->
|
||
let p1 = size vg p t1 in
|
||
let p2 = size vg V2.(p + v (x p1) 0.) t2 in
|
||
V2.(v (x p1 +. x p2) (Float.max (y p1) (y p2)))
|
||
| Vcompose (t1, t2) ->
|
||
let p1 = size vg p t1 in
|
||
let p2 = size vg V2.(p + v 0. (y p1)) t2 in
|
||
V2.(v (Float.max (x p1) (x p2)) (y p1 +. y p2))
|
||
| Zcompose (t1, t2) -> p2_max (size vg p t1) (size vg p t2)
|
||
| Hcrop (t, left, right) ->
|
||
(* positive values are crop, negative is pad *)
|
||
V2.(size vg (p - v left 0.) t - v right 0.)
|
||
| Vcrop (t, top, bottom) ->
|
||
V2.(size vg (p - v 0. top) t - v 0. bottom)
|
||
| Void p' -> V2.(p + p')
|
||
|
||
let empty = Empty
|
||
let void w h = Void (P2.v w h)
|
||
|
||
let attr a = function
|
||
| Attr (t, a0) -> Attr (t, A.(replace ~prev:a0 ~next:a))
|
||
| t -> Attr (t, a)
|
||
|
||
let ( <|> ) t1 t2 =
|
||
match (t1, t2) with
|
||
| _, Empty -> t1
|
||
| Empty, _ -> t2
|
||
| _ -> Hcompose (t1, t2)
|
||
|
||
let ( <-> ) t1 t2 =
|
||
match (t1, t2) with
|
||
| _, Empty -> t1
|
||
| Empty, _ -> t2
|
||
| _ -> Vcompose (t1, t2)
|
||
|
||
let ( </> ) t1 t2 =
|
||
match (t1, t2) with
|
||
| _, Empty -> t1
|
||
| Empty, _ -> t2
|
||
| _ -> Zcompose (t1, t2)
|
||
|
||
(* crop is positive value, pad is negative *)
|
||
|
||
let hcrop left right img =
|
||
(* 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); *)
|
||
Vcrop (img, top, bottom)
|
||
|
||
let crop ?(l = 0.) ?(r = 0.) ?(t = 0.) ?(b = 0.) img =
|
||
let img = if l <> 0. || r <> 0. then hcrop l r img else img in
|
||
if t <> 0. || b <> 0. then vcrop t b img else img
|
||
|
||
let hpad left right img = hcrop (-.left) (-.right) img
|
||
let vpad top bottom img = vcrop (-.top) (-.bottom) img
|
||
|
||
let pad ?(l = 0.) ?(r = 0.) ?(t = 0.) ?(b = 0.) img =
|
||
crop ~l:(-.l) ~r:(-.r) ~t:(-.t) ~b:(-.b) img
|
||
|
||
let rec concatm z ( @ ) xs =
|
||
let rec accum ( @ ) = function
|
||
| ([] | [ _ ]) as xs -> xs
|
||
| a :: b :: xs -> (a @ b) :: accum ( @ ) xs
|
||
in
|
||
match xs with
|
||
| [] -> z
|
||
| [ x ] -> x
|
||
| xs -> concatm z ( @ ) (accum ( @ ) xs)
|
||
|
||
let hcat = concatm empty ( <|> )
|
||
let vcat = concatm empty ( <-> )
|
||
let zcat xs = List.fold_right ( </> ) xs empty
|
||
|
||
let text attr tx =
|
||
match attr with Some a -> Attr (Segment tx, a) | _ -> Segment tx
|
||
|
||
let string ?attr s = text attr (Text.of_string s)
|
||
let uchars ?attr a = text attr (Text.of_uchars a)
|
||
|
||
let rec linspcm z ( @ ) x n f =
|
||
match n with
|
||
| 0. -> z
|
||
| 1. -> f x
|
||
| _ ->
|
||
let m = n /. 2. in
|
||
linspcm z ( @ ) x m f @ linspcm z ( @ ) (x +. m) (n -. m) f
|
||
|
||
let tabulate m n f =
|
||
let m = max m 0. and n = max n 0. in
|
||
linspcm empty ( <-> ) 0. n (fun y ->
|
||
linspcm empty ( <|> ) 0. m (fun x -> f x y))
|
||
|
||
let chars ctor ?attr c w h =
|
||
let w = max 0. w and h = max 0. h in
|
||
if w < 1. || h < 1. then void w h
|
||
else
|
||
let line = text attr (ctor w c) in
|
||
tabulate 1. h (fun _ _ -> line)
|
||
|
||
let char = chars Text.replicatec
|
||
(* let uchar = chars Text.replicateu *)
|
||
|
||
(* module Fmt = struct
|
||
open Format
|
||
|
||
type stag += Attr of A.t
|
||
|
||
let push r x = r := x :: !r
|
||
let pop r = r := match !r with _ :: xs -> xs | _ -> []
|
||
let top_a r = match !r with a :: _ -> a | _ -> A.empty
|
||
|
||
let create () =
|
||
let img, line, attr = (ref empty, ref empty, ref []) in
|
||
let fmt =
|
||
formatter_of_out_functions
|
||
{
|
||
out_flush =
|
||
(fun () ->
|
||
img := !img <-> !line;
|
||
line := empty;
|
||
attr := []);
|
||
out_newline =
|
||
(fun () ->
|
||
img := !img <-> !line;
|
||
line := void 0. 1.);
|
||
out_string =
|
||
(fun s i n ->
|
||
line :=
|
||
!line
|
||
<|> string ~attr:(top_a attr)
|
||
String.(sub0cp s i n))
|
||
(* Not entirely clear; either or both could be void: *);
|
||
out_spaces =
|
||
(fun w ->
|
||
line := !line <|> char ~attr:(top_a attr) ' ' w 1);
|
||
out_indent =
|
||
(fun w ->
|
||
line := !line <|> char ~attr:(top_a attr) ' ' w 1);
|
||
}
|
||
in
|
||
pp_set_formatter_stag_functions fmt
|
||
{
|
||
(pp_get_formatter_stag_functions fmt ()) with
|
||
mark_open_stag =
|
||
(function
|
||
| Attr a ->
|
||
push attr A.(top_a attr ++ a);
|
||
""
|
||
| _ -> "");
|
||
mark_close_stag =
|
||
(fun _ ->
|
||
pop attr;
|
||
"");
|
||
};
|
||
pp_set_mark_tags fmt true;
|
||
( fmt,
|
||
fun () ->
|
||
let i = !img in
|
||
img := empty;
|
||
line := empty;
|
||
attr := [];
|
||
i )
|
||
|
||
let ppf, reset = create ()
|
||
|
||
let kstrf ?(attr = A.empty) ?(w = 1000000) k format =
|
||
let m = ref 0 in
|
||
let f1 _ () =
|
||
m := pp_get_margin ppf ();
|
||
pp_set_margin ppf w;
|
||
pp_open_stag ppf (Attr attr)
|
||
and k _ =
|
||
pp_print_flush ppf ();
|
||
pp_set_margin ppf !m;
|
||
reset () |> k
|
||
in
|
||
kfprintf k ppf ("%a" ^^ format) f1 ()
|
||
|
||
let strf ?attr ?w format = kstrf ?attr ?w (fun i -> i) format
|
||
|
||
let attr attr f fmt x =
|
||
pp_open_stag fmt (Attr attr);
|
||
f fmt x;
|
||
pp_close_stag fmt ()
|
||
end
|
||
|
||
let kstrf, strf, pp_attr = Fmt.(kstrf, strf, attr) *)
|
||
|
||
module Draw = struct
|
||
type attr = Style.t
|
||
type p = P2.t
|
||
type d = [ `X | `Y | `Z ]
|
||
|
||
let str_of_box b =
|
||
Printf.sprintf "(ox:%0.1f oy:%0.1f ex%0.1f ey%0.1f)" (Box2.ox b)
|
||
(Box2.oy b) (Box2.maxx b) (Box2.maxy b)
|
||
|
||
let fill_box vg color b =
|
||
let module Path = NVG.Path in
|
||
let open NVG in
|
||
NVG.save vg;
|
||
Path.begin_ vg;
|
||
Path.rect vg ~x:(Box2.ox b) ~y:(Box2.oy b) ~w:(Box2.w b)
|
||
~h:(Box2.h b);
|
||
set_fill_color vg ~color;
|
||
fill vg;
|
||
NVG.restore vg;
|
||
(* Log.debug (fun m -> m "fill_box: %a" Box2.pp b); *)
|
||
Box2.size b
|
||
|
||
let path_box vg color ?(width = 0.) b =
|
||
let module Path = NVG.Path in
|
||
Path.begin_ vg;
|
||
Path.rect vg ~x:(Box2.ox b) ~y:(Box2.oy b) ~w:(Box2.w b)
|
||
~h:(Box2.h b);
|
||
if width != 0. then NVG.set_stroke_width vg ~width;
|
||
NVG.set_stroke_color vg ~color;
|
||
NVG.stroke vg;
|
||
Box2.size b
|
||
|
||
let vcat d a b =
|
||
match d with
|
||
| `X ->
|
||
V2.v (V2.x a +. V2.x b) (Float.max_num (V2.y a) (V2.y b))
|
||
| `Y -> V2.v (Float.max_num (V2.x a) (V2.x b)) (V2.y a +. V2.y b)
|
||
| `Z ->
|
||
V2.v
|
||
(Float.max_num (V2.x a) (V2.x b))
|
||
(Float.max_num (V2.y a) (V2.y b))
|
||
|
||
let rec pp ?(attr = A.empty) ppf : t -> unit =
|
||
let open F in
|
||
let compose = pair (parens (pp ~attr)) (parens (pp ~attr)) in
|
||
function
|
||
| Empty -> fmt "Empty" ppf
|
||
| 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.(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
|
||
| Hcrop (t, left, right) ->
|
||
fmt "Hcrop (%.1f,%.1f,%a)" ppf left right (pp ~attr) t
|
||
| Vcrop (t, top, bottom) ->
|
||
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)
|
||
s;
|
||
|
||
let sz =
|
||
V2.v (bounds_segment vg p (Text.of_string s)).advance
|
||
metrics.line_height
|
||
in
|
||
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 *)
|
||
let b' =
|
||
match n with
|
||
| Empty | Void _ -> p
|
||
| Segment text -> segment vg p text
|
||
| Attr (i, a) ->
|
||
let a0 = A.(replace ~prev:attr ~next:a) in
|
||
if
|
||
(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) != 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
|
||
| Hcompose (i1, i2) ->
|
||
let p1 = node vg attr p i1 in
|
||
let p2 = node vg attr V2.(p + v (V2.x p1) 0.) i2 in
|
||
V2.(v (x p1 +. x p2) (Float.max (y p1) (y p2)))
|
||
| Vcompose (i1, i2) ->
|
||
let p1 = node vg attr p i1 in
|
||
let p2 = node vg attr V2.(p + v 0. (V2.y p1)) i2 in
|
||
V2.(v (Float.max (x p1) (x p2)) (y p1 +. y p2))
|
||
| Zcompose (i1, i2) ->
|
||
let p1 = node vg attr p i1 in
|
||
let p2 = node vg attr p i2 in
|
||
p2_max p1 p2
|
||
| Hcrop (i, left, right) ->
|
||
let p0 = size vg p i in
|
||
NVG.save vg;
|
||
NVG.Scissor.scissor vg ~x:(V2.x p) ~y:(V2.y p)
|
||
~w:(V2.x p0 -. right)
|
||
~h:(V2.y p0);
|
||
let p1 = node vg attr V2.(p - v left 0.) i in
|
||
NVG.restore vg;
|
||
V2.(p1 - v (left +. right) 0.)
|
||
| Vcrop (i, top, bottom) ->
|
||
let p0 = size vg p i in
|
||
NVG.save vg;
|
||
NVG.Scissor.scissor vg ~x:(V2.x p) ~y:(V2.y p)
|
||
~w:(V2.x p0)
|
||
~h:(V2.y p0 -. bottom);
|
||
let p1 = node vg attr V2.(p - v 0. top) i in
|
||
NVG.restore vg;
|
||
V2.(p1 - v 0. (top +. bottom))
|
||
in
|
||
|
||
(* ignore
|
||
(path_box vg.vg
|
||
(NVG.Color.rgbaf ~r:1. ~g:0. ~b:0. ~a:0.2)
|
||
(Box2.of_pts b b')); *)
|
||
b'
|
||
end
|
||
end
|
||
|
||
module Nottui = struct
|
||
let maxi x y : int = if x > y then x else y
|
||
let mini x y : int = if x < y then x else y
|
||
|
||
module Focus : sig
|
||
type var = int Lwd.var
|
||
type handle
|
||
|
||
val make : unit -> handle
|
||
val request : handle -> unit
|
||
val request_var : var -> unit
|
||
val release : handle -> unit
|
||
|
||
type status = Empty | Handle of int * var | Conflict of int
|
||
|
||
val empty : status
|
||
|
||
(*val is_empty : status -> bool*)
|
||
val status : handle -> status Lwd.t
|
||
val has_focus : status -> bool
|
||
val merge : status -> status -> status
|
||
val pp_var : Format.formatter -> var -> unit
|
||
val pp_status : Format.formatter -> status -> unit
|
||
end = struct
|
||
type var = int Lwd.var
|
||
type status = Empty | Handle of int * var | Conflict of int
|
||
type handle = var * status Lwd.t
|
||
|
||
let make () =
|
||
let v = Lwd.var 0 in
|
||
(v, Lwd.map ~f:(fun i -> Handle (i, v)) (Lwd.get v))
|
||
|
||
let empty : status = Empty
|
||
let status (h : handle) : status Lwd.t = snd h
|
||
|
||
let has_focus = function
|
||
| Empty -> false
|
||
| Handle (i, _) | Conflict i -> i > 0
|
||
|
||
let clock = ref 0
|
||
|
||
let request_var (v : var) =
|
||
incr clock;
|
||
Log.debug (fun m ->
|
||
m "Focus.request_var v=%d clock=%d" (Lwd.peek v) !clock);
|
||
Lwd.set v !clock
|
||
|
||
let request ((v, _) : handle) = request_var v
|
||
|
||
let release ((v, _) : handle) =
|
||
incr clock;
|
||
Lwd.set v 0
|
||
|
||
let merge s1 s2 : status =
|
||
match (s1, s2) with
|
||
| (Empty | Handle (0, _)), x | x, (Empty | Handle (0, _)) -> x
|
||
| Handle (i1, _), Handle (i2, _) when i1 = i2 -> s1
|
||
| (Handle (i1, _) | Conflict i1), Conflict i2 when i1 < i2 -> s2
|
||
| (Handle (i1, _) | Conflict i1), Handle (i2, _) when i1 < i2 ->
|
||
Conflict i2
|
||
| Conflict _, (Handle (_, _) | Conflict _) -> s1
|
||
| Handle (i1, _), (Handle (_, _) | Conflict _) -> Conflict i1
|
||
|
||
let pp_var ppf v = F.pf ppf "%d" (Lwd.peek v)
|
||
|
||
let pp_status ppf = function
|
||
| Empty -> F.pf ppf "Empty"
|
||
| Handle (i, v) -> F.pf ppf "Handle (%d, %a)" i pp_var v
|
||
| Conflict i -> F.pf ppf "Conflict %d" i
|
||
end
|
||
|
||
module Gravity : sig
|
||
type direction = [ `Negative | `Neutral | `Positive ]
|
||
|
||
val pp_direction : Format.formatter -> direction -> unit
|
||
|
||
type t
|
||
|
||
val pp : Format.formatter -> t -> unit
|
||
val make : h:direction -> v:direction -> t
|
||
val default : t
|
||
val h : t -> direction
|
||
val v : t -> direction
|
||
|
||
type t2
|
||
|
||
val pair : t -> t -> t2
|
||
val p1 : t2 -> t
|
||
val p2 : t2 -> t
|
||
end = struct
|
||
type direction = [ `Negative | `Neutral | `Positive ]
|
||
type t = { h : direction; v : direction }
|
||
|
||
let default = { h = `Neutral; v = `Neutral }
|
||
let make ~h ~v = { h; v }
|
||
let h x = x.h
|
||
let v x = x.v
|
||
|
||
let pp_direction ppf dir =
|
||
let text =
|
||
match dir with
|
||
| `Negative -> "`Negative"
|
||
| `Neutral -> "`Neutral"
|
||
| `Positive -> "`Positive"
|
||
in
|
||
Format.pp_print_string ppf text
|
||
|
||
let pp ppf g =
|
||
Format.fprintf ppf "{ h = %a; v = %a }" pp_direction (h g)
|
||
pp_direction (v g)
|
||
|
||
type t2 = t * t
|
||
|
||
let pair t1 t2 = (t1, t2)
|
||
let p1 (t, _) = t
|
||
let p2 (_, t) = t
|
||
end
|
||
|
||
type gravity = Gravity.t
|
||
|
||
module Interval : sig
|
||
type t
|
||
|
||
val make : float -> float -> t
|
||
val shift : t -> float -> t
|
||
val fst : t -> float
|
||
val snd : t -> float
|
||
val size : t -> float
|
||
val zero : t
|
||
end = struct
|
||
type t = float * float
|
||
|
||
let make x y = (x, y)
|
||
let shift (x, y) d = (x +. d, y +. d)
|
||
let fst (x, _) = x
|
||
let size (x, y) = y -. x
|
||
let snd (_, y) = y
|
||
let zero = (0., 0.)
|
||
end
|
||
|
||
module Ui = struct
|
||
type may_handle = [ `Unhandled | `Handled ]
|
||
|
||
let may_handle (type a) (v : a option) (f : a -> may_handle) :
|
||
may_handle =
|
||
match v with Some v' -> f v' | None -> `Unhandled
|
||
|
||
let pp_may_handle ppf = function
|
||
| `Unhandled -> F.pf ppf "`Unhandled"
|
||
| `Handled -> F.pf ppf "`Handled"
|
||
|
||
type mouse_handler =
|
||
x:float ->
|
||
y:float ->
|
||
Input.button ->
|
||
[ `Unhandled
|
||
| `Handled
|
||
| `Grab of
|
||
(x:float -> y:float -> unit) * (x:float -> y:float -> unit)
|
||
]
|
||
|
||
type semantic_key =
|
||
[ (* Clipboard *)
|
||
`Copy
|
||
| `Paste
|
||
| (* Focus management *)
|
||
`Focus of
|
||
[ `Next | `Prev | `Left | `Right | `Up | `Down ] ]
|
||
|
||
type key =
|
||
[ Input.special | `Uchar of Uchar.t | semantic_key ]
|
||
* Input.mods
|
||
|
||
let pp_key =
|
||
F.(
|
||
pair ~sep:F.sp
|
||
(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 =
|
||
[ `Key of key | `Mouse of mouse | `Paste of Input.paste ]
|
||
|
||
type layout_spec = {
|
||
w : float;
|
||
h : float;
|
||
sw : float;
|
||
sh : float;
|
||
}
|
||
|
||
let pp_float ppf = F.fmt "%.1f" ppf
|
||
|
||
type flags = int
|
||
|
||
let flags_none = 0
|
||
let flag_transient_sensor = 1
|
||
let flag_permanent_sensor = 2
|
||
|
||
type size_sensor = w:float -> h:float -> unit
|
||
|
||
type frame_sensor =
|
||
x:float -> y:float -> w:float -> h:float -> unit -> unit
|
||
|
||
type image = I.t
|
||
type cache = { vx : Interval.t; vy : Interval.t; image : image }
|
||
|
||
type 'a desc =
|
||
| Atom of image
|
||
| Size_sensor of 'a * size_sensor
|
||
| Transient_sensor of 'a * frame_sensor
|
||
| Permanent_sensor of 'a * frame_sensor
|
||
| Resize of 'a * float option * float option * Gravity.t2
|
||
| Mouse_handler of 'a * mouse_handler
|
||
| Focus_area of 'a * (key -> may_handle)
|
||
| Shift_area of 'a * float * float
|
||
| Event_filter of
|
||
'a * ([ `Key of key | `Mouse of mouse ] -> may_handle)
|
||
| X of 'a * 'a
|
||
| Y of 'a * 'a
|
||
| Z of 'a * 'a
|
||
|
||
type t = {
|
||
mutable w : float;
|
||
mutable h : float;
|
||
sw : float;
|
||
sh : float;
|
||
mutable desc : t desc;
|
||
focus : Focus.status;
|
||
mutable flags : flags;
|
||
mutable sensor_cache : (float * float * float * float) option;
|
||
mutable cache : cache;
|
||
}
|
||
|
||
let layout_spec (t : t) : layout_spec =
|
||
{ w = t.w; h = t.h; sw = t.sw; sh = t.sh }
|
||
|
||
let layout_width t = t.w
|
||
let layout_stretch_width t = t.sw
|
||
let layout_height t = t.h
|
||
let layout_stretch_height t = t.sh
|
||
|
||
let pp_layout_spec ppf { w; h; sw; sh; _ } =
|
||
let p = pp_float in
|
||
Format.fprintf ppf "{w=%a;@ h=%a;@ sw=%a;@ sh=%a}" p w p h p sw
|
||
p sh
|
||
|
||
let cache : cache =
|
||
{ vx = Interval.zero; vy = Interval.zero; image = I.empty }
|
||
|
||
let empty : t =
|
||
{
|
||
w = 0.;
|
||
h = 0.;
|
||
sw = 0.;
|
||
sh = 0.;
|
||
flags = flags_none;
|
||
focus = Focus.empty;
|
||
desc = Atom I.empty;
|
||
sensor_cache = None;
|
||
cache;
|
||
}
|
||
|
||
let atom img : t =
|
||
{
|
||
w = 0.;
|
||
h = 0.;
|
||
sw = 0.;
|
||
sh = 0.;
|
||
focus = Focus.empty;
|
||
flags = flags_none;
|
||
desc = Atom img;
|
||
sensor_cache = None;
|
||
cache;
|
||
}
|
||
|
||
(* let space_1_0 = atom (I.void 1 0)
|
||
let space_0_1 = atom (I.void 0 1)
|
||
let space_1_1 = atom (I.void 1 1)
|
||
|
||
let space x y =
|
||
match (x, y) with
|
||
| 0, 0 -> empty
|
||
| 1, 0 -> space_1_0
|
||
| 0, 1 -> space_0_1
|
||
| 1, 1 -> space_1_1
|
||
| _ -> atom (I.void x y) *)
|
||
|
||
let space x y = atom (I.void x y)
|
||
let mouse_area f t : t = { t with desc = Mouse_handler (t, f) }
|
||
|
||
let keyboard_area ?focus f (t : t) : t =
|
||
let focus =
|
||
match focus with
|
||
| None -> t.focus
|
||
| Some focus -> Focus.merge focus t.focus
|
||
in
|
||
{ t with desc = Focus_area (t, f); focus }
|
||
|
||
let shift_area x y t : t = { t with desc = Shift_area (t, x, y) }
|
||
|
||
let size_sensor handler t : t =
|
||
{ t with desc = Size_sensor (t, handler) }
|
||
|
||
let transient_sensor frame_sensor t =
|
||
{
|
||
t with
|
||
desc = Transient_sensor (t, frame_sensor);
|
||
flags = t.flags lor flag_transient_sensor;
|
||
}
|
||
|
||
let permanent_sensor frame_sensor t =
|
||
{
|
||
t with
|
||
desc = Permanent_sensor (t, frame_sensor);
|
||
flags = t.flags lor flag_permanent_sensor;
|
||
}
|
||
|
||
let prepare_gravity = function
|
||
| None, None -> Gravity.(pair default default)
|
||
| Some g, None | None, Some g -> Gravity.(pair g g)
|
||
| Some pad, Some crop -> Gravity.(pair pad crop)
|
||
|
||
let resize ?w ?h ?sw ?sh ?pad ?crop ?(attr = A.empty) (t : t) : t
|
||
=
|
||
let _ = attr in
|
||
let wo, ho = (w, h) in
|
||
let g = prepare_gravity (pad, crop) in
|
||
match ((w, t.w), (h, t.h), (sw, t.sw), (sh, t.sh)) with
|
||
| ( (Some w, _ | _, w),
|
||
(Some h, _ | _, h),
|
||
(Some sw, _ | _, sw),
|
||
(Some sh, _ | _, sh) ) ->
|
||
{ t with w; h; sw; sh; desc = Resize (t, wo, ho, g) }
|
||
|
||
let resize_to (l : layout_spec) ?pad ?crop ?(attr = A.empty) t : t
|
||
=
|
||
let _ = attr in
|
||
let g = prepare_gravity (pad, crop) in
|
||
{ t with desc = Resize (t, Some l.w, Some l.h, g) }
|
||
|
||
let event_filter ?focus f (t : t) : t =
|
||
let focus =
|
||
match focus with None -> t.focus | Some focus -> focus
|
||
in
|
||
{ t with desc = Event_filter (t, f); focus }
|
||
|
||
let join_x (a : t) (b : t) =
|
||
{
|
||
empty with
|
||
w = a.w +. b.w;
|
||
h = max a.h b.h;
|
||
sw = a.sw +. b.sw;
|
||
sh = max a.sh b.sh;
|
||
flags = a.flags lor b.flags;
|
||
focus = Focus.merge a.focus b.focus;
|
||
desc = X (a, b);
|
||
}
|
||
|
||
let join_y (a : t) (b : t) =
|
||
{
|
||
empty with
|
||
w = max a.w b.w;
|
||
h = a.h +. b.h;
|
||
sw = max a.sw b.sw;
|
||
sh = a.sh +. b.sh;
|
||
flags = a.flags lor b.flags;
|
||
focus = Focus.merge a.focus b.focus;
|
||
desc = Y (a, b);
|
||
}
|
||
|
||
let join_z (a : t) (b : t) =
|
||
{
|
||
empty with
|
||
w = max a.w b.w;
|
||
h = max a.h b.h;
|
||
sw = max a.sw b.sw;
|
||
sh = max a.sh b.sh;
|
||
flags = a.flags lor b.flags;
|
||
focus = Focus.merge a.focus b.focus;
|
||
desc = Z (a, b);
|
||
}
|
||
|
||
let pack_x = (empty, join_x)
|
||
let pack_y = (empty, join_y)
|
||
let pack_z = (empty, join_z)
|
||
let hcat xs = Lwd_utils.reduce pack_x xs
|
||
let vcat xs = Lwd_utils.reduce pack_y xs
|
||
let zcat xs = Lwd_utils.reduce pack_z xs
|
||
let has_focus t = Focus.has_focus t.focus
|
||
|
||
let rec pp ppf t =
|
||
F.pf ppf "@[<hov>focus=%a %a@]" Focus.pp_status t.focus pp_desc
|
||
t.desc
|
||
|
||
and pp_desc ppf = function
|
||
| Atom a ->
|
||
Format.fprintf ppf "Atom @[<hov>(%a)@]"
|
||
(I.Draw.pp ?attr:None) a
|
||
| Size_sensor (desc, _) ->
|
||
Format.fprintf ppf "Size_sensor (%a, _)" pp desc
|
||
| Transient_sensor (desc, _) ->
|
||
Format.fprintf ppf "Transient_sensor (%a,@ _)" pp desc
|
||
| Permanent_sensor (desc, _) ->
|
||
Format.fprintf ppf "Permanent_sensor (%a,@ _)" pp desc
|
||
| Resize (desc, x, y, _gravity) ->
|
||
F.pf ppf "Resize (%a, %a,@ _,@ %a)" (F.option pp_float) x
|
||
(F.option pp_float) y
|
||
(* Gravity.pp (Gravity.p1 gravity) Gravity.pp
|
||
(Gravity.p2 gravity) *)
|
||
pp desc
|
||
| Mouse_handler (n, _) ->
|
||
Format.fprintf ppf "%a" (*"Mouse (%a,@ _)"*) pp n
|
||
| Focus_area (n, _) -> Format.fprintf ppf "Focus (%a,@ _)" pp n
|
||
| Shift_area (n, x, y) ->
|
||
Format.fprintf ppf "Shift (%.0f,%.0f,%a)" x y pp n
|
||
| Event_filter (n, _) ->
|
||
Format.fprintf ppf "Event (%a,@ _)" pp n
|
||
| X (a, b) -> Format.fprintf ppf "X (@[%a,@ %a@])" pp a pp b
|
||
| Y (a, b) -> Format.fprintf ppf "Y (@[%a,@ %a@])" pp a pp b
|
||
| Z (a, b) -> Format.fprintf ppf "Z (@[%a,@ %a@])" pp a pp b
|
||
|
||
let iter f ui =
|
||
match ui.desc with
|
||
| Atom _ -> ()
|
||
| Size_sensor (u, _)
|
||
| Transient_sensor (u, _)
|
||
| Permanent_sensor (u, _)
|
||
| Resize (u, _, _, _)
|
||
| Mouse_handler (u, _)
|
||
| Focus_area (u, _)
|
||
| Shift_area (u, _, _)
|
||
| Event_filter (u, _) ->
|
||
f u
|
||
| X (u1, u2) | Y (u1, u2) | Z (u1, u2) ->
|
||
f u1;
|
||
f u2
|
||
end
|
||
|
||
type ui = Ui.t
|
||
|
||
module Renderer = struct
|
||
open Ui
|
||
|
||
type size = Gg.p2
|
||
|
||
type grab_function =
|
||
(x:float -> y:float -> unit) * (x:float -> y:float -> unit)
|
||
|
||
type t = {
|
||
vg : NVG.t;
|
||
mutable size : size;
|
||
mutable view : ui;
|
||
mutable mouse_grab : grab_function option;
|
||
}
|
||
|
||
let make vg () =
|
||
{ vg; mouse_grab = None; size = P2.o; view = Ui.empty }
|
||
|
||
let size t = t.size
|
||
|
||
let solve_focus (ui : ui) i =
|
||
let rec aux ui =
|
||
match ui.focus with
|
||
| Focus.Empty | Focus.Handle (0, _) -> ()
|
||
| Focus.Handle (i', _) when i = i' -> ()
|
||
| Focus.Handle (_, v) -> Lwd.set v 0
|
||
| Focus.Conflict _ -> iter aux ui
|
||
in
|
||
aux ui
|
||
|
||
let split ~a ~sa ~b ~sb total =
|
||
let stretch = sa +. sb in
|
||
let flex = total -. a -. b in
|
||
let a', b' =
|
||
if stretch > 0. && flex > 0. then
|
||
let ratio =
|
||
if sa > sb then flex *. sa /. stretch
|
||
else flex -. (flex *. sb /. stretch)
|
||
in
|
||
(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'); *)
|
||
(a', b')
|
||
|
||
let pack ~fixed ~stretch total g1 g2 =
|
||
let v1, v2 =
|
||
let flex = total -. fixed in
|
||
if stretch > 0. && flex > 0. then (0., total)
|
||
else
|
||
let gravity = if flex >= 0. then g1 else g2 in
|
||
match gravity with
|
||
| `Negative -> (0., fixed)
|
||
| `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); *)
|
||
(v1, v2)
|
||
|
||
let has_transient_sensor flags =
|
||
flags land flag_transient_sensor <> 0
|
||
|
||
let has_permanent_sensor flags =
|
||
flags land flag_permanent_sensor <> 0
|
||
|
||
let rec update_sensors ox oy sw sh (ui : ui) =
|
||
if
|
||
has_transient_sensor ui.flags
|
||
|| has_permanent_sensor ui.flags
|
||
&&
|
||
match ui.sensor_cache with
|
||
| None -> false
|
||
| Some (ox', oy', sw', sh') ->
|
||
ox = ox' && oy = oy' && sw = sw' && sh = sh'
|
||
then (
|
||
ui.flags <- ui.flags land lnot flag_transient_sensor;
|
||
if has_permanent_sensor ui.flags then
|
||
ui.sensor_cache <- Some (ox, oy, sw, sh);
|
||
match ui.desc with
|
||
| Atom _ -> ()
|
||
| Size_sensor (t, _)
|
||
| Mouse_handler (t, _)
|
||
| Focus_area (t, _)
|
||
| Event_filter (t, _) ->
|
||
update_sensors ox oy sw sh t
|
||
| Transient_sensor (t, sensor) ->
|
||
ui.desc <- t.desc;
|
||
let sensor = sensor ~x:ox ~y:oy ~w:sw ~h:sh in
|
||
update_sensors ox oy sw sh t;
|
||
sensor ()
|
||
| Permanent_sensor (t, sensor) ->
|
||
let sensor = sensor ~x:ox ~y:oy ~w:sw ~h:sh in
|
||
update_sensors ox oy sw sh t;
|
||
sensor ()
|
||
| Resize (t, x, y, g) ->
|
||
let open Gravity in
|
||
let dx, rw =
|
||
pack
|
||
~fixed:(Option.value x ~default:t.w)
|
||
~stretch:t.sw sw
|
||
(h (p1 g))
|
||
(h (p2 g))
|
||
in
|
||
let dy, rh =
|
||
pack
|
||
~fixed:(Option.value y ~default:t.h)
|
||
~stretch:t.sh sh
|
||
(v (p1 g))
|
||
(v (p2 g))
|
||
in
|
||
update_sensors (ox +. dx) (oy +. dy) rw rh t
|
||
| Shift_area (t, sx, sy) ->
|
||
update_sensors (ox -. sx) (oy -. sy) sw sh t
|
||
| X (a, b) ->
|
||
let aw, bw = split ~a:a.w ~sa:a.sw ~b:b.w ~sb:b.sw sw in
|
||
update_sensors ox oy aw sh a;
|
||
update_sensors (ox +. aw) oy bw sh b
|
||
| Y (a, b) ->
|
||
let ah, bh = split ~a:a.h ~sa:a.sh ~b:b.h ~sb:b.sh sh in
|
||
update_sensors ox oy sw ah a;
|
||
update_sensors ox (oy +. ah) sw bh b
|
||
| Z (a, b) ->
|
||
update_sensors ox oy sw sh a;
|
||
update_sensors ox oy sw sh b)
|
||
|
||
let update_focus ui =
|
||
match ui.focus with
|
||
| Focus.Empty | Focus.Handle _ -> ()
|
||
| Focus.Conflict i -> solve_focus ui i
|
||
|
||
let rec t_size_desc_of_t vg (size : box2) (ui : Ui.t desc) =
|
||
match ui with
|
||
| Atom _ as a -> a
|
||
| Size_sensor (t, v) -> Size_sensor (t_size_of_t vg size t, v)
|
||
| Mouse_handler (t, v) ->
|
||
Mouse_handler (t_size_of_t vg size t, v)
|
||
| Focus_area (t, v) -> Focus_area (t_size_of_t vg size t, v)
|
||
| Event_filter (t, v) -> Event_filter (t_size_of_t vg size t, v)
|
||
| Transient_sensor (t, v) ->
|
||
Transient_sensor (t_size_of_t vg size t, v)
|
||
| Permanent_sensor (t, v) ->
|
||
Permanent_sensor (t_size_of_t vg size t, v)
|
||
| Resize (t, w, h, g2) ->
|
||
Resize
|
||
( t_size_of_t vg
|
||
(Box2.v (Box2.o size)
|
||
(V2.v
|
||
(Option.value w ~default:(Box2.w size))
|
||
(Option.value h ~default:(Box2.h size))))
|
||
t,
|
||
w,
|
||
h,
|
||
g2 )
|
||
| Shift_area (t, sx, sy) ->
|
||
Shift_area
|
||
( t_size_of_t vg
|
||
(Box2.of_pts
|
||
V2.(Box2.o size - of_tuple (sx, sy))
|
||
(Box2.max size))
|
||
t,
|
||
sx,
|
||
sy )
|
||
| X (a, b) ->
|
||
let a' = t_size_of_t vg size a in
|
||
let b' =
|
||
t_size_of_t vg
|
||
(Box2.of_pts
|
||
V2.(v (Box2.minx size +. a'.w) (Box2.miny size))
|
||
(Box2.max size))
|
||
b
|
||
in
|
||
X (a', b')
|
||
| Y (a, b) ->
|
||
let a' = t_size_of_t vg size a in
|
||
let b' =
|
||
t_size_of_t vg
|
||
(Box2.of_pts
|
||
V2.(v (Box2.minx size) (Box2.miny size +. a'.h))
|
||
(Box2.max size))
|
||
b
|
||
in
|
||
Y (a', b')
|
||
| Z (a, b) -> Z (t_size_of_t vg size a, t_size_of_t vg size b)
|
||
|
||
and t_size_of_t vg (size : box2) (ui : Ui.t) : ui =
|
||
let desc = t_size_desc_of_t vg size ui.desc in
|
||
let w, h =
|
||
match desc with
|
||
| Atom i -> V2.to_tuple (I.size vg (Box2.o size) i)
|
||
| Size_sensor (t, _)
|
||
| Mouse_handler (t, _)
|
||
| Focus_area (t, _)
|
||
| Event_filter (t, _)
|
||
| Transient_sensor (t, _)
|
||
| Permanent_sensor (t, _) ->
|
||
(t.w, t.h)
|
||
| Resize (t, w, h, _) ->
|
||
(Option.value w ~default:t.w, Option.value h ~default:t.h)
|
||
| Shift_area (t, x, y) -> (t.w +. x, t.h +. y)
|
||
| X (a, b) -> (a.w +. b.w, max a.h b.h)
|
||
| 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; desc; sensor_cache = None; cache }
|
||
|
||
let update t size (ui : Ui.t) =
|
||
t.size <- size;
|
||
t.view <- t_size_of_t t.vg (Box2.v V2.zero size) ui;
|
||
update_sensors 0. 0. (P2.x size) (P2.y size) t.view;
|
||
update_focus t.view
|
||
|
||
let dispatch_mouse st x y btn w h t =
|
||
let handle ox oy f =
|
||
match f ~x:(x -. ox) ~y:(y -. oy) btn with
|
||
| `Unhandled -> false
|
||
| `Handled -> true
|
||
| `Grab f ->
|
||
st.mouse_grab <- Some f;
|
||
true
|
||
in
|
||
let rec aux ox oy sw sh t =
|
||
match t.desc with
|
||
| Atom _ -> false
|
||
| X (a, b) ->
|
||
let aw, bw = split ~a:a.w ~sa:a.sw ~b:b.w ~sb:b.sw sw in
|
||
if x -. ox < aw then aux ox oy aw sh a
|
||
else aux (ox +. aw) oy bw sh b
|
||
| Y (a, b) ->
|
||
let ah, bh = split ~a:a.h ~sa:a.sh ~b:b.h ~sb:b.sh sh in
|
||
if y -. oy < ah then aux ox oy sw ah a
|
||
else aux ox (oy +. ah) sw bh b
|
||
| Z (a, b) -> aux ox oy sw sh b || aux ox oy sw sh a
|
||
| Mouse_handler (t, f) ->
|
||
let _offsetx, rw =
|
||
pack ~fixed:t.w ~stretch:t.sw sw `Negative `Negative
|
||
and _offsety, rh =
|
||
pack ~fixed:t.h ~stretch:t.sh sh `Negative `Negative
|
||
in
|
||
assert (_offsetx = 0. && _offsety = 0.);
|
||
(x -. ox >= 0.
|
||
&& x -. ox <= rw
|
||
&& y -. oy >= 0.
|
||
&& y -. oy <= rh)
|
||
&& (aux ox oy sw sh t || handle ox oy f)
|
||
| Size_sensor (desc, _)
|
||
| Transient_sensor (desc, _)
|
||
| Permanent_sensor (desc, _)
|
||
| Focus_area (desc, _) ->
|
||
aux ox oy sw sh desc
|
||
| Shift_area (desc, sx, sy) ->
|
||
aux (ox -. sx) (oy -. sy) sw sh desc
|
||
| 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
|
||
aux (ox +. dx) (oy +. dy) rw rh t
|
||
| Event_filter (n, f) -> (
|
||
match f (`Mouse (`Press btn, (x, y), [])) with
|
||
| `Handled -> true
|
||
| `Unhandled -> aux ox oy sw sh n)
|
||
in
|
||
aux 0. 0. w h t
|
||
|
||
let release_grab st x y =
|
||
match st.mouse_grab with
|
||
| None -> ()
|
||
| Some (_, release) ->
|
||
st.mouse_grab <- None;
|
||
release ~x ~y
|
||
|
||
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); *)
|
||
if w <> rw || h <> rh then I.pad ~r:(rw -. w) ~b:(rh -. h) image
|
||
else image
|
||
|
||
let resize_canvas2 vg ox oy rw rh image =
|
||
let w, h = V2.to_tuple @@ I.size vg V2.zero image in
|
||
I.pad ~l:ox ~t:oy ~r:(rw -. w -. ox) ~b:(rh -. h -. oy) image
|
||
|
||
let same_size vg w h image =
|
||
V2.(equal (of_tuple (w, h)) (I.size vg V2.zero image))
|
||
|
||
let dispatch_mouse t (event, (x, y), _mods) =
|
||
if
|
||
match event with
|
||
| `Press btn ->
|
||
release_grab t x y;
|
||
let w, h = V2.to_tuple t.size in
|
||
dispatch_mouse t x y btn w h t.view
|
||
| `Drag -> (
|
||
match t.mouse_grab with
|
||
| None -> false
|
||
| Some (drag, _) ->
|
||
drag ~x ~y;
|
||
true)
|
||
| `Release ->
|
||
release_grab t x y;
|
||
true
|
||
then `Handled
|
||
else `Unhandled
|
||
|
||
let rec 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); *)
|
||
if
|
||
let cache = t.cache in
|
||
vx1 >= Interval.fst cache.vx
|
||
&& vy1 >= Interval.fst cache.vy
|
||
&& vx2 <= Interval.snd cache.vx
|
||
&& vy2 <= Interval.snd cache.vy
|
||
then t.cache
|
||
else if vx2 < 0. || vy2 < 0. || sw < vx1 || sh < vy1 then
|
||
{
|
||
vx = Interval.make vx1 vx2;
|
||
vy = Interval.make vy1 vy2;
|
||
image = I.void sw sh;
|
||
}
|
||
else
|
||
let cache =
|
||
match t.desc with
|
||
| Atom image ->
|
||
let image =
|
||
if Focus.has_focus t.focus then (
|
||
Log.debug (fun m -> m "render_node Atom has_focus");
|
||
I.attr A.clickable image)
|
||
else image
|
||
in
|
||
{
|
||
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
|
||
|
||
let image vg { size; view; _ } =
|
||
let w, h = V2.to_tuple size in
|
||
Log.debug (fun m -> m "Renderer.image view=%a " Ui.pp view);
|
||
(render_node vg 0. 0. w h w h view).image
|
||
|
||
let dispatch_raw_key st key =
|
||
let rec iter (st : ui list) : [> `Unhandled ] =
|
||
match st with
|
||
| [] -> `Unhandled
|
||
| ui :: tl -> (
|
||
match ui.desc with
|
||
| Atom _ -> iter tl
|
||
| X (a, b) | Y (a, b) | Z (a, b) ->
|
||
(* Try left/top most branch first *)
|
||
let st' =
|
||
if Focus.has_focus b.focus then b :: tl
|
||
else a :: b :: tl
|
||
in
|
||
iter st'
|
||
| Focus_area (t, f) -> (
|
||
match iter [ t ] with
|
||
| `Handled -> `Handled
|
||
| `Unhandled -> (
|
||
match f key with
|
||
| `Handled -> `Handled
|
||
| `Unhandled -> iter tl))
|
||
| Mouse_handler (t, _)
|
||
| Size_sensor (t, _)
|
||
| Transient_sensor (t, _)
|
||
| Permanent_sensor (t, _)
|
||
| Shift_area (t, _, _)
|
||
| Resize (t, _, _, _) ->
|
||
iter (t :: tl)
|
||
| Event_filter (t, f) -> (
|
||
match f (`Key key) with
|
||
| `Unhandled -> iter (t :: tl)
|
||
| `Handled -> `Handled))
|
||
in
|
||
iter [ st.view ]
|
||
|
||
exception Acquired_focus
|
||
|
||
let grab_focus ui =
|
||
let rec aux ui =
|
||
match ui.focus with
|
||
| Focus.Empty -> ()
|
||
| Focus.Handle (_, v) ->
|
||
Focus.request_var v;
|
||
raise Acquired_focus
|
||
| Focus.Conflict _ -> iter aux ui
|
||
in
|
||
Log.debug (fun m -> m "grab_focus");
|
||
try
|
||
aux ui;
|
||
false
|
||
with Acquired_focus ->
|
||
Log.warn (fun m -> m "grab_focus Acquired_focus -> true");
|
||
true
|
||
|
||
let rec dispatch_focus t dir =
|
||
match t.desc with
|
||
| Atom _ -> false
|
||
| Mouse_handler (t, _)
|
||
| Size_sensor (t, _)
|
||
| Transient_sensor (t, _)
|
||
| Permanent_sensor (t, _)
|
||
| Shift_area (t, _, _)
|
||
| Resize (t, _, _, _)
|
||
| 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_area has_focus t'.focus = \
|
||
true");
|
||
|
||
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
|
||
||
|
||
match dir with
|
||
| `Next | `Right -> dispatch_focus b dir
|
||
| _ -> false
|
||
else if Focus.has_focus b.focus then
|
||
dispatch_focus b dir
|
||
||
|
||
match dir with
|
||
| `Prev | `Left -> dispatch_focus a dir
|
||
| _ -> false
|
||
else
|
||
match dir with
|
||
| `Prev | `Left | `Up ->
|
||
dispatch_focus b dir || dispatch_focus a dir
|
||
| `Next | `Down | `Right ->
|
||
dispatch_focus a dir || dispatch_focus b dir)
|
||
| Y (a, b) -> (
|
||
if Focus.has_focus a.focus then
|
||
dispatch_focus a dir
|
||
||
|
||
match dir with
|
||
| `Next | `Down -> dispatch_focus b dir
|
||
| _ -> false
|
||
else if Focus.has_focus b.focus then
|
||
dispatch_focus b dir
|
||
||
|
||
match dir with
|
||
| `Prev | `Up -> dispatch_focus a dir
|
||
| _ -> false
|
||
else
|
||
match dir with
|
||
| `Prev | `Up ->
|
||
dispatch_focus b dir || dispatch_focus a dir
|
||
| `Next | `Left | `Down | `Right ->
|
||
dispatch_focus a dir || dispatch_focus b dir)
|
||
| Z (a, b) ->
|
||
if Focus.has_focus a.focus then dispatch_focus a dir
|
||
else dispatch_focus b dir || dispatch_focus a dir
|
||
|
||
let rec dispatch_key st key =
|
||
match (dispatch_raw_key st key, key) with
|
||
| `Handled, _ -> `Handled
|
||
| `Unhandled, (`Arrow dir, []) ->
|
||
let dir : [ `Down | `Left | `Right | `Up ] :>
|
||
[ `Down | `Left | `Right | `Up | `Next | `Prev ] =
|
||
dir
|
||
in
|
||
dispatch_key st (`Focus dir, [ `Meta ])
|
||
| `Unhandled, (`Tab, mods) ->
|
||
let dir = if List.mem `Shift mods then `Prev else `Next in
|
||
dispatch_key st (`Focus dir, mods)
|
||
| `Unhandled, (`Focus dir, _) ->
|
||
let r = dispatch_focus st.view dir in
|
||
(if r then Log.debug else Log.warn) (fun m ->
|
||
m "Renderer.dispatch_focus key:%a -> %b" pp_key key r);
|
||
if r then `Handled else `Unhandled
|
||
| `Unhandled, _ -> `Unhandled
|
||
|
||
let dispatch_event t = function
|
||
| `Key key -> dispatch_key t key
|
||
| `Mouse mouse -> dispatch_mouse t mouse
|
||
| `Paste _ -> `Unhandled
|
||
end
|
||
end
|
||
|
||
module Nottui_lwt = struct
|
||
open Nottui
|
||
|
||
(* stolen from let-def/lwd/lib/nottui/nottui.ml* etc... *)
|
||
let copy_until quit ~f input =
|
||
let quit = Lwt.map (fun () -> None) quit in
|
||
let stream, push = Lwt_stream.create () in
|
||
let rec aux () =
|
||
Lwt.bind (Lwt.choose [ quit; Lwt_stream.peek input ])
|
||
@@ fun result ->
|
||
match result with
|
||
| None ->
|
||
push None;
|
||
Lwt.return_unit
|
||
| Some x ->
|
||
push (Some (f x));
|
||
Lwt.bind (Lwt_stream.junk input) aux
|
||
in
|
||
Lwt.async aux;
|
||
stream
|
||
|
||
let render vg ?quit ~size events doc =
|
||
let renderer = Renderer.make vg () in
|
||
let refresh_stream, push_refresh = Lwt_stream.create () in
|
||
let root =
|
||
Lwd.observe
|
||
~on_invalidate:(fun _ ->
|
||
if not (Lwt_stream.is_closed refresh_stream) then
|
||
push_refresh (Some ()))
|
||
doc
|
||
in
|
||
let quit, do_quit =
|
||
match quit with
|
||
| Some quit -> (quit, None)
|
||
| None ->
|
||
let t, u = Lwt.wait () in
|
||
(t, Some u)
|
||
in
|
||
let events =
|
||
copy_until quit events ~f:(fun e ->
|
||
(e
|
||
: [ `Resize of _ | Ui.event ]
|
||
:> [ `Resize of _ | Ui.event ]))
|
||
in
|
||
let size = ref size in
|
||
let result, push = Lwt_stream.create () in
|
||
let refresh () =
|
||
(* FIXME This should use [Lwd.sample] with proper release management. *)
|
||
let ui = Lwd.quick_sample root in
|
||
Renderer.update renderer !size ui;
|
||
push (Some (Renderer.image vg renderer))
|
||
in
|
||
refresh ();
|
||
let process_event e =
|
||
match e with
|
||
| `Key (`Uchar c, [ `Meta ]) as event
|
||
when Uchar.(equal c (of_char 'q')) -> (
|
||
match do_quit with
|
||
| Some u -> Lwt.wakeup u ()
|
||
| None -> ignore (Renderer.dispatch_event renderer event))
|
||
| #Ui.event as event -> (
|
||
match Renderer.dispatch_event renderer event with
|
||
| `Handled -> ()
|
||
| `Unhandled ->
|
||
(* Log.warn (fun m ->
|
||
m
|
||
"Nottui_lwt.render process_event #Ui.event -> \
|
||
`Unhandled") *)
|
||
())
|
||
| `Resize size' ->
|
||
size := size';
|
||
refresh ()
|
||
in
|
||
Lwt.async (fun () ->
|
||
Lwt.finalize
|
||
(fun () -> Lwt_stream.iter process_event events)
|
||
(fun () ->
|
||
push None;
|
||
Lwt.return_unit));
|
||
Lwt.async (fun () -> Lwt_stream.iter refresh refresh_stream);
|
||
result
|
||
|
||
(* let run ?quit doc =
|
||
let term = Term.create () in
|
||
let images =
|
||
render ?quit ~size:(Term.size term) (Term.events term) doc
|
||
in
|
||
Lwt.finalize
|
||
(fun () -> Lwt_stream.iter_s (Term.image term) images)
|
||
(fun () -> Term.release term) *)
|
||
end
|
||
|
||
module Nottui_widgets = struct
|
||
open Nottui
|
||
|
||
let string ?(attr = A.empty) str = Ui.atom (I.string ~attr str)
|
||
let int ?attr x = string ?attr (string_of_int x)
|
||
let bool ?attr x = string ?attr (string_of_bool x)
|
||
let float_ ?attr x = string ?attr (string_of_float x)
|
||
let printf ?attr fmt = Printf.ksprintf (string ?attr) fmt
|
||
let fmt ?attr fmt = Format.kasprintf (string ?attr) fmt
|
||
|
||
let kprintf k ?attr fmt =
|
||
Printf.ksprintf (fun str -> k (string ?attr str)) fmt
|
||
|
||
let kfmt k ?attr fmt =
|
||
Format.kasprintf (fun str -> k (string ?attr str)) fmt
|
||
|
||
type window_manager = {
|
||
overlays : ui Lwd.t Lwd_table.t;
|
||
view : ui Lwd.t;
|
||
}
|
||
|
||
let window_manager base =
|
||
let overlays = Lwd_table.make () in
|
||
let composition =
|
||
Lwd.join
|
||
(Lwd_table.reduce (Lwd_utils.lift_monoid Ui.pack_z) overlays)
|
||
in
|
||
let view =
|
||
Lwd.map2 base composition ~f:(fun base composite ->
|
||
Ui.join_z base
|
||
(Ui.resize_to (Ui.layout_spec base) composite))
|
||
in
|
||
{ overlays; view }
|
||
|
||
let window_manager_view wm = wm.view
|
||
let window_manager_overlays wm = wm.overlays
|
||
|
||
let menu_overlay wm g ?(dx = 0.) ?(dy = 0.) body around =
|
||
let sensor ~x ~y ~w ~h () =
|
||
let row = Lwd_table.append (window_manager_overlays wm) in
|
||
let h_pad =
|
||
match Gravity.h g with
|
||
| `Negative -> Ui.space (x +. dx) 0.
|
||
| `Neutral -> Ui.space (x +. dx +. (w /. 2.)) 0.
|
||
| `Positive -> Ui.space (x +. dx +. w) 0.
|
||
in
|
||
let v_pad =
|
||
match Gravity.v g with
|
||
| `Negative -> Ui.space 0. (y +. dy)
|
||
| `Neutral -> Ui.space 0. (y +. dy +. (h /. 2.))
|
||
| `Positive -> Ui.space 0. (y +. dy +. h)
|
||
in
|
||
let view =
|
||
Lwd.map body ~f:(fun body ->
|
||
let body =
|
||
let pad = Ui.space 1. 0. in
|
||
Ui.join_x pad (Ui.join_x body pad)
|
||
in
|
||
let bg =
|
||
Ui.resize_to (Ui.layout_spec body)
|
||
~attr:A.(bg Color.lightgreen)
|
||
Ui.empty
|
||
in
|
||
let catchall =
|
||
Ui.mouse_area
|
||
(fun ~x:_ ~y:_ -> function
|
||
| `Left ->
|
||
Lwd_table.remove row;
|
||
`Handled
|
||
| _ -> `Handled)
|
||
(Ui.resize ~sw:1. ~sh:1. Ui.empty)
|
||
in
|
||
Ui.join_z catchall @@ Ui.join_y v_pad @@ Ui.join_x h_pad
|
||
@@ Ui.join_z bg body)
|
||
in
|
||
Lwd_table.set row view
|
||
in
|
||
Ui.transient_sensor sensor around
|
||
|
||
(* let menu_overlay wm ?(dx = 0) ?(dy = 0) handler body =
|
||
let refresh = Lwd.var () in
|
||
let clicked = ref false in
|
||
Lwd.map' body @@ fun body ->
|
||
let body =
|
||
let pad = Ui.space 1 0 in
|
||
Ui.join_x pad (Ui.join_x body pad)
|
||
in
|
||
let bg =
|
||
Ui.resize_to (Ui.layout_spec body)
|
||
~bg:A.(bg lightgreen)
|
||
Ui.empty
|
||
in
|
||
let click_handler ~x:_ ~y:_ = function
|
||
| `Left ->
|
||
clicked := true;
|
||
Lwd.set refresh ();
|
||
`Handled
|
||
| _ -> `Unhandled
|
||
in
|
||
let ui = Ui.mouse_area click_handler (Ui.join_z bg body) in
|
||
if !clicked then (
|
||
clicked := false;
|
||
let sensor ~x ~y ~w:_ ~h () =
|
||
let row = Lwd_table.append (window_manager_overlays wm) in
|
||
let h_pad = Ui.space (x + dx) 0 in
|
||
let v_pad = Ui.space 0 (y + h + dy) in
|
||
let view =
|
||
Lwd.map' (handler ()) @@ fun view ->
|
||
let catchall =
|
||
Ui.mouse_area
|
||
(fun ~x:_ ~y:_ -> function
|
||
| `Left ->
|
||
Lwd_table.remove row;
|
||
`Handled
|
||
| _ -> `Handled)
|
||
(Ui.resize ~sw:1 ~sh:1 Ui.empty)
|
||
in
|
||
Ui.join_z catchall (Ui.join_y v_pad (Ui.join_x h_pad view))
|
||
in
|
||
Lwd_table.set row view
|
||
in
|
||
Ui.transient_sensor sensor ui)
|
||
else ui *)
|
||
|
||
let scroll_step = 7.
|
||
|
||
let scroll_area ?(offset = (0., 0.)) t =
|
||
let offset = Lwd.var offset in
|
||
let scroll d_x d_y =
|
||
let s_x, s_y = Lwd.peek offset in
|
||
let s_x = max 0. (s_x +. d_x) in
|
||
let s_y = max 0. (s_y +. d_y) in
|
||
Lwd.set offset (s_x, s_y);
|
||
`Handled
|
||
in
|
||
let focus_handler = function
|
||
| `Arrow `Left, [] -> scroll (-.scroll_step) 0.
|
||
| `Arrow `Right, [] -> scroll (+.scroll_step) 0.
|
||
| `Arrow `Up, [] -> scroll 0. (-.scroll_step)
|
||
| `Arrow `Down, [] -> scroll 0. (+.scroll_step)
|
||
| `Page `Up, [] -> scroll 0. (-.scroll_step *. 8.)
|
||
| `Page `Down, [] -> scroll 0. (+.scroll_step *. 8.)
|
||
| _ -> `Unhandled
|
||
in
|
||
(* let scroll_handler ~x:_ ~y:_ = function
|
||
| `Scroll `Up -> scroll 0. (-.scroll_step)
|
||
| `Scroll `Down -> scroll 0. (+.scroll_step)
|
||
| _ -> `Unhandled
|
||
in *)
|
||
Lwd.map2 t (Lwd.get offset) ~f:(fun t (s_x, s_y) ->
|
||
t |> Ui.shift_area s_x s_y
|
||
(*|> Ui.mouse_area scroll_handler*)
|
||
|> Ui.keyboard_area focus_handler)
|
||
|
||
let main_menu_item wm text f =
|
||
let text = string ~attr:A.menu_main (" " ^ text ^ " ") in
|
||
let refresh = Lwd.var () in
|
||
let overlay = ref false in
|
||
let on_click ~x:_ ~y:_ = function
|
||
| `Left ->
|
||
overlay := true;
|
||
Lwd.set refresh ();
|
||
`Handled
|
||
| _ -> `Unhandled
|
||
in
|
||
Lwd.map (Lwd.get refresh) ~f:(fun () ->
|
||
let ui = Ui.mouse_area on_click text in
|
||
if !overlay then (
|
||
overlay := false;
|
||
menu_overlay wm
|
||
(Gravity.make ~h:`Negative ~v:`Positive)
|
||
(f ()) ui)
|
||
else ui)
|
||
|
||
let sub_menu_item wm text f =
|
||
let text = string ~attr:A.menu_sub text in
|
||
let refresh = Lwd.var () in
|
||
let overlay = ref false in
|
||
let on_click ~x:_ ~y:_ = function
|
||
| `Left ->
|
||
overlay := true;
|
||
Lwd.set refresh ();
|
||
`Handled
|
||
| _ -> `Unhandled
|
||
in
|
||
Lwd.map (Lwd.get refresh) ~f:(fun () ->
|
||
let ui = Ui.mouse_area on_click text in
|
||
if !overlay then (
|
||
overlay := false;
|
||
menu_overlay wm
|
||
(Gravity.make ~h:`Positive ~v:`Negative)
|
||
(f ()) ui)
|
||
else ui)
|
||
|
||
let sub_entry text f =
|
||
let text = string ~attr:A.menu_sub text in
|
||
let on_click ~x:_ ~y:_ = function
|
||
| `Left ->
|
||
f ();
|
||
`Handled
|
||
| _ -> `Unhandled
|
||
in
|
||
Ui.mouse_area on_click text
|
||
|
||
type pane_state =
|
||
| Split of { pos : float; max : float }
|
||
| Re_split of { pos : float; max : float; at : float }
|
||
|
||
let h_pane left right =
|
||
let state_var = Lwd.var (Split { pos = 5.; max = 10. }) in
|
||
let render state (l, r) =
|
||
let (Split { pos; max } | Re_split { pos; max; _ }) = state in
|
||
let l = Ui.resize ~w:0. ~h:0. ~sh:1. ~sw:pos l in
|
||
let r = Ui.resize ~w:0. ~h:0. ~sh:1. ~sw:(max -. pos) r in
|
||
let splitter =
|
||
Ui.resize
|
||
~attr:A.(bg Color.lightyellow)
|
||
~w:1. ~h:0. ~sw:0. ~sh:1. Ui.empty
|
||
in
|
||
let splitter =
|
||
Ui.mouse_area
|
||
(fun ~x:_ ~y:_ -> function
|
||
| `Left ->
|
||
`Grab
|
||
( (fun ~x ~y:_ ->
|
||
match Lwd.peek state_var with
|
||
| Split { pos; max } ->
|
||
Lwd.set state_var
|
||
(Re_split { pos; max; at = x })
|
||
| Re_split { pos; max; at } ->
|
||
if at <> x then
|
||
Lwd.set state_var
|
||
(Re_split { pos; max; at = x })),
|
||
fun ~x:_ ~y:_ -> () )
|
||
| _ -> `Unhandled)
|
||
splitter
|
||
in
|
||
let ui = Ui.join_x l (Ui.join_x splitter r) in
|
||
let ui = Ui.resize ~w:100. ~h:100. ~sw:10. ~sh:10. ui in
|
||
let ui =
|
||
match state with
|
||
| Split _ -> ui
|
||
| Re_split { at; _ } ->
|
||
Ui.transient_sensor
|
||
(fun ~x ~y:_ ~w ~h:_ () ->
|
||
Lwd.set state_var (Split { pos = at -. x; max = w }))
|
||
ui
|
||
in
|
||
ui
|
||
in
|
||
Lwd.map2 ~f:render (Lwd.get state_var) (Lwd.pair left right)
|
||
|
||
let v_pane top bot =
|
||
let state_var = Lwd.var (Split { pos = 5.; max = 10. }) in
|
||
let render state (top, bot) =
|
||
let (Split { pos; max } | Re_split { pos; max; _ }) = state in
|
||
let top = Ui.resize ~w:0. ~h:0. ~sw:1. ~sh:pos top in
|
||
let bot = Ui.resize ~w:0. ~h:0. ~sw:1. ~sh:(max -. pos) bot in
|
||
let splitter =
|
||
Ui.resize
|
||
~attr:A.(bg Color.lightyellow)
|
||
~w:0. ~h:1. ~sw:1. ~sh:0. Ui.empty
|
||
in
|
||
let splitter =
|
||
Ui.mouse_area
|
||
(fun ~x:_ ~y:_ -> function
|
||
| `Left ->
|
||
`Grab
|
||
( (fun ~x:_ ~y ->
|
||
match Lwd.peek state_var with
|
||
| Split { pos; max } ->
|
||
Lwd.set state_var
|
||
(Re_split { pos; max; at = y })
|
||
| Re_split { pos; max; at } ->
|
||
if at <> y then
|
||
Lwd.set state_var
|
||
(Re_split { pos; max; at = y })),
|
||
fun ~x:_ ~y:_ -> () )
|
||
| _ -> `Unhandled)
|
||
splitter
|
||
in
|
||
let ui = Ui.join_y top (Ui.join_y splitter bot) in
|
||
let ui = Ui.resize ~w:10. ~h:10. ~sw:1. ~sh:1. ui in
|
||
let ui =
|
||
match state with
|
||
| Split _ -> ui
|
||
| Re_split { at; _ } ->
|
||
Ui.transient_sensor
|
||
(fun ~x:_ ~y ~w:_ ~h () ->
|
||
Lwd.set state_var (Split { pos = at -. y; max = h }))
|
||
ui
|
||
in
|
||
ui
|
||
in
|
||
Lwd.map2 ~f:render (Lwd.get state_var) (Lwd.pair top bot)
|
||
|
||
let eq_uc_c uc c = Uchar.(equal uc (of_char c))
|
||
|
||
let edit_field ?(focus = Focus.make ()) ?(on_change = Fun.id) state
|
||
=
|
||
let update focus_h focus (text, pos) =
|
||
let pos = min (max 0 pos) (String.length text) in
|
||
let content =
|
||
Ui.atom @@ I.hcat
|
||
@@
|
||
if Focus.has_focus focus then
|
||
let attr = A.clickable in
|
||
let len = String.length text in
|
||
if pos >= len then
|
||
[ I.string ~attr text; I.string ~attr:A.cursor " " ]
|
||
else
|
||
[
|
||
I.string ~attr (String.sub text 0 pos);
|
||
I.string ~attr:A.cursor (String.sub text pos 1);
|
||
I.string ~attr
|
||
(String.sub text (pos + 1) (len - pos - 1));
|
||
]
|
||
else [ I.string (if text = "" then " " else text) ]
|
||
in
|
||
let handler k =
|
||
let on_change a =
|
||
Lwd.set state (on_change a);
|
||
`Handled
|
||
in
|
||
(match k with
|
||
| `Uchar c, [ `Ctrl ] when Uchar.(equal c (of_char 'U')) ->
|
||
on_change ("", 0) (* clear *)
|
||
| `Uchar u, [ `Ctrl ] when eq_uc_c u 'k' ->
|
||
(* TODO put killed text into kill-ring *)
|
||
if pos < String.length text then
|
||
on_change (String.sub text 0 pos, pos)
|
||
else `Unhandled (* kill *)
|
||
| `Backspace, [] ->
|
||
if pos > 0 then
|
||
let text =
|
||
if pos < String.length text then
|
||
String.sub text 0 (pos - 1)
|
||
^ String.sub text pos (String.length text - pos)
|
||
else if String.length text > 0 then
|
||
String.sub text 0 (String.length text - 1)
|
||
else text
|
||
in
|
||
let pos = max 0 (pos - 1) in
|
||
on_change (text, pos)
|
||
else `Unhandled
|
||
| `Uchar k, [] ->
|
||
let k = Uchar.unsafe_to_char k in
|
||
let text =
|
||
if pos < String.length text then
|
||
String.sub text 0 pos ^ String.make 1 k
|
||
^ String.sub text pos (String.length text - pos)
|
||
else text ^ String.make 1 k
|
||
in
|
||
on_change (text, pos + 1)
|
||
| `Escape, [] ->
|
||
Focus.release focus_h;
|
||
`Handled
|
||
(* | `Enter, _ ->
|
||
on_submit (text, pos);
|
||
`Handled *)
|
||
| `Arrow `Left, [] ->
|
||
if pos > 0 then on_change (text, pos - 1) else `Unhandled
|
||
| `Arrow `Right, [] ->
|
||
let pos = pos + 1 in
|
||
if pos <= String.length text then on_change (text, pos)
|
||
else `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
|
||
let node =
|
||
Lwd.map2 ~f:(update focus) (Focus.status focus) (Lwd.get state)
|
||
in
|
||
node
|
||
(* let mouse_grab (text, pos) ~x ~y:_ = function
|
||
| `Left ->
|
||
if x <> pos then on_change (text, x);
|
||
Nottui.Focus.request focus;
|
||
`Handled
|
||
| _ -> `Unhandled
|
||
in
|
||
Lwd.map2 state node ~f:(fun state content ->
|
||
Ui.mouse_area (mouse_grab state) content *)
|
||
|
||
open Lwd.Infix
|
||
|
||
type line = {
|
||
focus : Focus.handle;
|
||
state : (string * int) Lwd.var;
|
||
ui : Ui.t Lwd.t;
|
||
}
|
||
|
||
type lines = line Lwd_table.t
|
||
|
||
let line_empty () =
|
||
let focus = Focus.make () in
|
||
let state = Lwd.var ("", 0) in
|
||
{ focus; state; ui = edit_field ~focus state }
|
||
|
||
let line_make ?(focus = Focus.make ()) str =
|
||
let state = Lwd.var (str, 0) in
|
||
{ focus; state; ui = edit_field ~focus state }
|
||
|
||
let line_append ?(table = Lwd_table.make ()) ?focus str =
|
||
let row = Lwd_table.append table in
|
||
Lwd_table.set row (line_make ?focus str)
|
||
|
||
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 row_of_cursor cursor f =
|
||
Ui.may_handle (Lwd.peek cursor) (fun row -> f row)
|
||
|
||
let line_of_cursor cursor
|
||
(f : line Lwd_table.row -> line -> Ui.may_handle) :
|
||
Ui.may_handle =
|
||
Ui.may_handle (Lwd.peek cursor) (fun row ->
|
||
Ui.may_handle (Lwd_table.get row) (fun line -> f row line))
|
||
|
||
let cursor_move cursor
|
||
(f : line Lwd_table.row -> line Lwd_table.row option) =
|
||
match Lwd.peek cursor with
|
||
| Some cursor_row -> (
|
||
match f cursor_row with
|
||
| Some new_row ->
|
||
(match Lwd_table.get new_row with
|
||
| Some new_line ->
|
||
cursor_row |> Lwd_table.get
|
||
|> Option.iter (fun cursor_line ->
|
||
copy_line_cursor cursor_line new_line;
|
||
Focus.release cursor_line.focus);
|
||
Focus.request new_line.focus
|
||
| None -> ());
|
||
Lwd.set cursor (Some new_row);
|
||
`Handled
|
||
| None -> `Unhandled)
|
||
| None -> `Unhandled
|
||
|
||
let multifield_of_string ?(table = Lwd_table.make ()) (s : string) :
|
||
line Lwd_table.t =
|
||
(* Append lines from s to table *)
|
||
List.iter (line_append ~table) (String.split_on_char '\n' s);
|
||
table
|
||
|
||
let rec focus_compare focus : int =
|
||
Focus.(
|
||
match focus with
|
||
| Empty -> 0
|
||
| Handle (i, _) -> i
|
||
| Conflict i -> i)
|
||
|
||
let rec find_focus (ui : ui) : ui =
|
||
Focus.(
|
||
match (ui.focus, ui.desc) with
|
||
| Empty, _ -> Ui.empty
|
||
| Handle (_, _), _ -> ui
|
||
| Conflict _, (X (a, b) | Y (a, b) | Z (a, b)) ->
|
||
if focus_compare a.focus < focus_compare b.focus then
|
||
find_focus b
|
||
else find_focus a
|
||
| Conflict _, Atom _ -> Ui.empty
|
||
| ( Conflict _,
|
||
( Size_sensor (t, _)
|
||
| Mouse_handler (t, _)
|
||
| Focus_area (t, _)
|
||
| Event_filter (t, _)
|
||
| Transient_sensor (t, _)
|
||
| Permanent_sensor (t, _)
|
||
| Resize (t, _, _, _)
|
||
| Shift_area (t, _, _) ) ) ->
|
||
find_focus t)
|
||
|
||
(* let focused_row_of_table (table : line Lwd_table.t) =
|
||
Lwd_table.map_reduce
|
||
(fun row (line : line) -> (Some row, line))
|
||
( (None, line_empty ()),
|
||
(fun a b -> if focus_compare (Focus.status (snd a).focus) < focus_compare ).focus then b else a) )
|
||
table *)
|
||
|
||
let focus_move table f = `Unhandled
|
||
|
||
let edit_area ?(table = Lwd_table.make ()) ?(focus = Focus.make ())
|
||
() : Ui.t Lwd.t =
|
||
(* create the cursor var and focus on first table row *)
|
||
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 (fun k ->
|
||
Log.debug (fun m ->
|
||
m "line_table handler %a" Ui.pp_key k);
|
||
match k with
|
||
| `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, [] ->
|
||
line_of_cursor cursor (fun old_row old_line ->
|
||
let str, pos = Lwd.peek old_line.state in
|
||
let o_str = String.sub str 0 pos in
|
||
let n_str =
|
||
String.(sub str pos (length str - pos))
|
||
in
|
||
Lwd.set old_line.state (o_str, pos);
|
||
let new_line = line_make n_str in
|
||
Focus.release old_line.focus;
|
||
Focus.request new_line.focus;
|
||
Lwd.set cursor
|
||
(Some (Lwd_table.after old_row ~set:new_line));
|
||
`Handled)
|
||
| `Backspace, [] ->
|
||
line_of_cursor cursor (fun row line ->
|
||
let str, pos = Lwd.peek line.state in
|
||
Ui.may_handle (Lwd_table.prev row)
|
||
(fun row_prev ->
|
||
if pos = 0 then
|
||
Ui.may_handle (Lwd_table.get row_prev)
|
||
(fun line_prev ->
|
||
let str_prev, _ =
|
||
Lwd.peek line_prev.state
|
||
in
|
||
Focus.release line.focus;
|
||
Focus.request line_prev.focus;
|
||
Lwd.set line_prev.state
|
||
( str_prev ^ str,
|
||
String.length str_prev );
|
||
Lwd.set cursor (Some row_prev);
|
||
Lwd_table.remove row;
|
||
`Handled)
|
||
else `Unhandled))
|
||
| `Uchar u, [ `Ctrl ] when eq_uc_c u 'k' -> `Handled
|
||
| _ -> `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
|
||
=
|
||
match tabs with
|
||
| [] -> Lwd.return Ui.empty
|
||
| _ ->
|
||
let cur = Lwd.var 0 in
|
||
Lwd.get cur >>= fun idx_sel ->
|
||
let _, f = List.nth tabs idx_sel in
|
||
let tab_bar =
|
||
tabs
|
||
|> List.mapi (fun i (s, _) ->
|
||
let attr =
|
||
if i = idx_sel then A.(bg Color.blue) else A.empty
|
||
in
|
||
let tab_annot = printf ~attr "[%s]" s in
|
||
Ui.mouse_area
|
||
(fun ~x:_ ~y:_ l ->
|
||
if l = `Left then (
|
||
Lwd.set cur i;
|
||
`Handled)
|
||
else `Unhandled)
|
||
tab_annot)
|
||
|> Ui.hcat
|
||
in
|
||
f () >|= Ui.join_y tab_bar
|
||
|
||
(*
|
||
(** Horizontal/vertical box. We fill lines until there is no room,
|
||
and then go to the next ligne. All widgets in a line are considered to
|
||
have the same height.
|
||
@param width dynamic width (default 80)
|
||
*)
|
||
let flex_box ?(w = Lwd.return 80) (l : Ui.t Lwd.t list) : Ui.t Lwd.t
|
||
=
|
||
Lwd_utils.flatten_l l >>= fun l ->
|
||
w >|= fun w_limit ->
|
||
let rec box_render (acc : Ui.t) (i : int) l : Ui.t =
|
||
match l with
|
||
| [] -> acc
|
||
| ui0 :: tl ->
|
||
let w0 = (Ui.layout_spec ui0).Ui.w in
|
||
if i + w0 >= w_limit then
|
||
(* newline starting with ui0 *)
|
||
Ui.join_y acc (box_render ui0 w0 tl)
|
||
else
|
||
(* same line *)
|
||
box_render (Ui.join_x acc ui0) (i + w0) tl
|
||
in
|
||
box_render Ui.empty 0 l
|
||
*)
|
||
|
||
(** Prints the summary, but calls [f()] to compute a sub-widget
|
||
when clicked on. Useful for displaying deep trees. *)
|
||
let unfoldable ?(folded_by_default = true) summary
|
||
(f : unit -> Ui.t Lwd.t) : Ui.t Lwd.t =
|
||
let open Lwd.Infix in
|
||
let opened = Lwd.var (not folded_by_default) in
|
||
let fold_content =
|
||
Lwd.get opened >>= function
|
||
| true ->
|
||
(* call [f] and pad a bit *)
|
||
f () |> Lwd.map ~f:(Ui.join_x (string " "))
|
||
| false -> Lwd.return Ui.empty
|
||
in
|
||
(* pad summary with a "> " when it's opened *)
|
||
let summary =
|
||
Lwd.get opened >>= fun op ->
|
||
summary >|= fun s ->
|
||
Ui.hcat
|
||
[
|
||
string ~attr:A.clickable (if op then "v" else ">");
|
||
string " ";
|
||
s;
|
||
]
|
||
in
|
||
let cursor ~x:_ ~y:_ = function
|
||
| `Left when Lwd.peek opened ->
|
||
Lwd.set opened false;
|
||
`Handled
|
||
| `Left ->
|
||
Lwd.set opened true;
|
||
`Handled
|
||
| _ -> `Unhandled
|
||
in
|
||
let mouse =
|
||
Lwd.map ~f:(fun m -> Ui.mouse_area cursor m) summary
|
||
in
|
||
Lwd.map2 mouse fold_content ~f:(fun summary fold ->
|
||
(* TODO: make this configurable/optional *)
|
||
(* newline if it's too big to fit on one line nicely *)
|
||
let spec_sum = Ui.layout_spec summary in
|
||
let spec_fold = Ui.layout_spec fold in
|
||
(* TODO: somehow, probe for available width here? *)
|
||
let too_big =
|
||
spec_fold.Ui.h > 20.
|
||
|| spec_fold.Ui.h > 20.
|
||
&& spec_sum.Ui.w +. spec_fold.Ui.w > 240.
|
||
in
|
||
if too_big then
|
||
Ui.join_y summary (Ui.join_x (string " ") fold)
|
||
else Ui.join_x summary fold)
|
||
|
||
let hbox l = Lwd_utils.pack Ui.pack_x l
|
||
let vbox l = Lwd_utils.pack Ui.pack_y l
|
||
let zbox l = Lwd_utils.pack Ui.pack_z l
|
||
|
||
let vlist ?(bullet = "- ") (l : Ui.t Lwd.t list) : Ui.t Lwd.t =
|
||
l
|
||
|> List.map (fun ui -> Lwd.map ~f:(Ui.join_x (string bullet)) ui)
|
||
|> vbox
|
||
|
||
(** A list of items with a dynamic filter on the items *)
|
||
let vlist_with ?(bullet = "- ")
|
||
?(filter = Lwd.return (fun _ -> true)) (f : 'a -> Ui.t Lwd.t)
|
||
(l : 'a list Lwd.t) : Ui.t Lwd.t =
|
||
let open Lwd.Infix in
|
||
let rec filter_map_ acc f l =
|
||
match l with
|
||
| [] -> List.rev acc
|
||
| x :: l' ->
|
||
let acc' =
|
||
match f x with None -> acc | Some y -> y :: acc
|
||
in
|
||
filter_map_ acc' f l'
|
||
in
|
||
let l =
|
||
l
|
||
>|= List.map (fun x ->
|
||
(x, Lwd.map ~f:(Ui.join_x (string bullet)) @@ f x))
|
||
in
|
||
let l_filter : _ list Lwd.t =
|
||
filter >>= fun filter ->
|
||
l
|
||
>|= filter_map_ [] (fun (x, ui) ->
|
||
if filter x then Some ui else None)
|
||
in
|
||
l_filter >>= Lwd_utils.pack Ui.pack_y
|
||
|
||
let vlist_of_text ?(focus = Focus.make ())
|
||
?(key_handler = fun _ -> `Unhandled) =
|
||
Lwd.map2 (Focus.status focus) ~f:(fun focus s ->
|
||
Ui.vcat @@ List.map string @@ String.split_on_char '\n' s
|
||
|> Ui.keyboard_area ~focus key_handler)
|
||
|
||
(* let rec iterate n f x = if n = 0 then x else iterate (n - 1) f (f x)
|
||
|
||
(** A grid layout, with alignment in all rows/columns.
|
||
@param max_h maximum height of a cell
|
||
@param max_w maximum width of a cell
|
||
@param bg attribute for controlling background style
|
||
@param h_space horizontal space between each cell in a row
|
||
@param v_space vertical space between each row
|
||
@param pad used to control padding of cells
|
||
@param crop used to control cropping of cells
|
||
TODO: control padding/alignment, vertically and horizontally
|
||
TODO: control align left/right in cells
|
||
TODO: horizontal rule below headers
|
||
TODO: headers *)
|
||
let grid ?max_h ?max_w ?pad ?crop ?bg ?(h_space = 0) ?(v_space = 0)
|
||
?(headers : Ui.t Lwd.t list option)
|
||
(rows : Ui.t Lwd.t list list) : Ui.t Lwd.t =
|
||
let rows =
|
||
match headers with None -> rows | Some r -> r :: rows
|
||
in
|
||
(* build a [ui list list Lwd.t] *)
|
||
Lwd_utils.map_l (fun r -> Lwd_utils.flatten_l r) rows
|
||
>>= fun (rows : Ui.t list list) ->
|
||
(* determine width of each column and height of each row *)
|
||
let n_cols =
|
||
List.fold_left (fun n r -> max n (List.length r)) 0 rows
|
||
in
|
||
let col_widths = Array.make n_cols 1 in
|
||
List.iter
|
||
(fun row ->
|
||
List.iteri
|
||
(fun col_j cell ->
|
||
let w = (Ui.layout_spec cell).Ui.w in
|
||
col_widths.(col_j) <- max col_widths.(col_j) w)
|
||
row)
|
||
rows;
|
||
(match max_w with
|
||
| None -> ()
|
||
| Some max_w ->
|
||
(* limit width *)
|
||
Array.iteri
|
||
(fun i x -> col_widths.(i) <- min x max_w)
|
||
col_widths);
|
||
(* now render, with some padding *)
|
||
let pack_pad_x =
|
||
if h_space <= 0 then (Ui.empty, Ui.join_x)
|
||
else (Ui.empty, fun x y -> Ui.hcat [ x; Ui.space h_space 0; y ])
|
||
and pack_pad_y =
|
||
if v_space = 0 then (Ui.empty, Ui.join_y)
|
||
else (Ui.empty, fun x y -> Ui.vcat [ x; Ui.space v_space 0; y ])
|
||
in
|
||
let rows =
|
||
List.map
|
||
(fun row ->
|
||
let row_h =
|
||
List.fold_left
|
||
(fun n c -> max n (Ui.layout_spec c).Ui.h)
|
||
0 row
|
||
in
|
||
let row_h =
|
||
match max_h with
|
||
| None -> row_h
|
||
| Some max_h -> min row_h max_h
|
||
in
|
||
let row =
|
||
List.mapi
|
||
(fun i c ->
|
||
Ui.resize ~w:col_widths.(i) ~h:row_h ?crop ?pad ?bg c)
|
||
row
|
||
in
|
||
Lwd_utils.reduce pack_pad_x row)
|
||
rows
|
||
in
|
||
(* TODO: mouse and keyboard handling *)
|
||
let ui = Lwd_utils.reduce pack_pad_y rows in
|
||
Lwd.return ui
|
||
*)
|
||
|
||
(** Turn the given [ui] into a clickable button, calls [f] when clicked. *)
|
||
let button_of ui f =
|
||
Ui.keyboard_area
|
||
(function
|
||
| `Enter, _ ->
|
||
f ();
|
||
`Handled
|
||
| _ -> `Unhandled)
|
||
(* @@ Ui.mouse_area
|
||
(fun ~x:_ ~y:_ _ ->
|
||
f ();
|
||
`Handled) *)
|
||
ui
|
||
|
||
(** A clickable button that calls [f] when clicked, labelled with a string. *)
|
||
let button ?(attr = A.clickable) s f = button_of (string ~attr s) f
|
||
|
||
(* file explorer for selecting a file *)
|
||
let file_select ?(abs = false) ?filter ~(on_select : string -> unit)
|
||
() : Ui.t Lwd.t =
|
||
let rec aux ~fold path =
|
||
try
|
||
let p_rel = if path = "" then "." else path in
|
||
if Sys.is_directory p_rel then
|
||
let ui () =
|
||
let arr = Sys.readdir p_rel in
|
||
let l =
|
||
Array.to_list arr |> List.map (Filename.concat path)
|
||
in
|
||
(* apply potential filter *)
|
||
let l =
|
||
match filter with
|
||
| None -> l
|
||
| Some f -> List.filter f l
|
||
in
|
||
let l = Lwd.return @@ List.sort String.compare l in
|
||
vlist_with ~bullet:"" (aux ~fold:true) l
|
||
in
|
||
if fold then
|
||
unfoldable ~folded_by_default:true
|
||
(Lwd.return @@ string @@ path ^ "/")
|
||
ui
|
||
else ui ()
|
||
else
|
||
Lwd.return
|
||
@@ button
|
||
~attr:A.(font Font.underline)
|
||
path
|
||
(fun () -> on_select path)
|
||
with e ->
|
||
Lwd.return
|
||
@@ Ui.vcat
|
||
[
|
||
printf
|
||
~attr:A.(bg Color.red)
|
||
"cannot list directory %s" path;
|
||
string @@ Printexc.to_string e;
|
||
]
|
||
in
|
||
let start = if abs then Sys.getcwd () else "" in
|
||
aux ~fold:false start
|
||
|
||
let toggle, toggle' =
|
||
let toggle_ st (lbl : string Lwd.t) (f : bool -> unit) :
|
||
Ui.t Lwd.t =
|
||
let mk_but st_v lbl_v =
|
||
let lbl =
|
||
Ui.hcat
|
||
[
|
||
printf "[%s|" lbl_v;
|
||
string ~attr:A.clickable (if st_v then "✔" else "×");
|
||
string "]";
|
||
]
|
||
in
|
||
button_of lbl (fun () ->
|
||
let new_st = not st_v in
|
||
Lwd.set st new_st;
|
||
f new_st)
|
||
in
|
||
Lwd.map2 ~f:mk_but (Lwd.get st) lbl
|
||
in
|
||
(* Similar to {!toggle}, except it directly reflects the state of a variable. *)
|
||
let toggle' (lbl : string Lwd.t) (v : bool Lwd.var) : Ui.t Lwd.t =
|
||
toggle_ v lbl (Lwd.set v)
|
||
(* a toggle, with a true/false state *)
|
||
and toggle ?(init = false) (lbl : string Lwd.t) (f : bool -> unit)
|
||
: Ui.t Lwd.t =
|
||
let st = Lwd.var init in
|
||
toggle_ st lbl f
|
||
in
|
||
(toggle, toggle')
|
||
|
||
type scrollbox_state = {
|
||
w : float;
|
||
h : float;
|
||
x : float;
|
||
y : float;
|
||
}
|
||
|
||
let adjust_offset visible total off =
|
||
let off =
|
||
if off +. visible > total then total -. visible else off
|
||
in
|
||
let off = if off < 0. then 0. else off in
|
||
off
|
||
|
||
let scrollbar_width = 10.
|
||
let decr_if x cond = if cond then x -. scrollbar_width else x
|
||
let scrollbar_bg = Color.gray 0.4
|
||
let scrollbar_fg = Color.gray 0.7
|
||
|
||
let scrollbar_click_step =
|
||
3. (* Clicking scrolls one third of the screen *)
|
||
|
||
let scrollbar_wheel_step =
|
||
8. (* Wheel event scrolls 1/8th of the screen *)
|
||
|
||
let hscrollbar visible total offset ~set =
|
||
let prefix = offset *. visible /. total in
|
||
let suffix = (total -. offset -. visible) *. visible /. total in
|
||
let handle = visible -. prefix -. suffix in
|
||
let render size color =
|
||
Ui.atom (I.attr (A.bg color) (I.void size scrollbar_width))
|
||
in
|
||
let mouse_handler ~x ~y:_ = function
|
||
| `Left ->
|
||
if x < prefix then (
|
||
set (offset -. max 1. (visible /. scrollbar_click_step));
|
||
`Handled)
|
||
else if x > prefix +. handle then (
|
||
set (offset +. max 1. (visible /. scrollbar_click_step));
|
||
`Handled)
|
||
else
|
||
`Grab
|
||
( (fun ~x:x' ~y:_ ->
|
||
set (offset +. ((x' -. x) *. total /. visible))),
|
||
fun ~x:_ ~y:_ -> () )
|
||
| `Scroll dir ->
|
||
let dir = match dir with `Down -> 1. | `Up -> -1. in
|
||
set
|
||
(offset
|
||
+. (dir *. max 1. (visible /. scrollbar_wheel_step)));
|
||
`Handled
|
||
| _ -> `Unhandled
|
||
in
|
||
let ( ++ ) = Ui.join_x in
|
||
Ui.mouse_area mouse_handler
|
||
(render prefix scrollbar_bg
|
||
++ render handle scrollbar_fg
|
||
++ render suffix scrollbar_bg)
|
||
|
||
let vscrollbar visible total offset ~set =
|
||
let prefix = offset *. visible /. total in
|
||
let suffix = (total -. offset -. visible) *. visible /. total in
|
||
let handle = visible -. prefix -. suffix in
|
||
let render size color =
|
||
Ui.atom (I.char ~attr:(A.bg color) ' ' 1. size)
|
||
in
|
||
let mouse_handler ~x:_ ~y = function
|
||
| `Left ->
|
||
if y < prefix then (
|
||
set (offset -. max 1. (visible /. scrollbar_click_step));
|
||
`Handled)
|
||
else if y > prefix +. handle then (
|
||
set (offset +. max 1. (visible /. scrollbar_click_step));
|
||
`Handled)
|
||
else
|
||
`Grab
|
||
( (fun ~x:_ ~y:y' ->
|
||
set (offset +. ((y' -. y) *. total /. visible))),
|
||
fun ~x:_ ~y:_ -> () )
|
||
| `Scroll dir ->
|
||
let dir = match dir with `Down -> 1. | `Up -> -1. in
|
||
set
|
||
(offset
|
||
+. (dir *. max 1. (visible /. scrollbar_wheel_step)));
|
||
`Handled
|
||
| _ -> `Unhandled
|
||
in
|
||
let ( ++ ) = Ui.join_y in
|
||
Ui.mouse_area mouse_handler
|
||
(render prefix scrollbar_bg
|
||
++ render handle scrollbar_fg
|
||
++ render suffix scrollbar_bg)
|
||
|
||
let scrollbox t =
|
||
(* Keep track of scroll state *)
|
||
let state_var = Lwd.var { w = 0.; h = 0.; x = 0.; y = 0. } in
|
||
(* Keep track of size available for display *)
|
||
let update_size ~w ~h =
|
||
let state = Lwd.peek state_var in
|
||
if state.w <> w || state.h <> h then
|
||
Lwd.set state_var { state with w; h }
|
||
in
|
||
let measure_size body =
|
||
Ui.size_sensor update_size
|
||
(Ui.resize ~w:0. ~h:0. ~sw:1. ~sh:1. body)
|
||
in
|
||
(* Given body and state, composite scroll bars *)
|
||
let compose_bars body state =
|
||
let bw, bh = (Ui.layout_width body, Ui.layout_height body) in
|
||
(* Logic to determine which scroll bar should be visible *)
|
||
let hvisible = state.w < bw and vvisible = state.h < bh in
|
||
let hvisible = hvisible || (vvisible && state.w = bw) in
|
||
let vvisible = vvisible || (hvisible && state.h = bh) in
|
||
(* Compute size and offsets based on visibility *)
|
||
let state_w = decr_if state.w vvisible in
|
||
let state_h = decr_if state.h hvisible in
|
||
let state_x = adjust_offset state_w bw state.x in
|
||
let state_y = adjust_offset state_h bh state.y in
|
||
(* Composite visible scroll bars *)
|
||
let crop b =
|
||
Ui.resize ~sw:scrollbar_width ~sh:scrollbar_width ~w:0. ~h:0.
|
||
(Ui.shift_area state_x state_y b)
|
||
in
|
||
let set_vscroll y =
|
||
let state = Lwd.peek state_var in
|
||
if state.y <> y then Lwd.set state_var { state with y }
|
||
in
|
||
let set_hscroll x =
|
||
let state = Lwd.peek state_var in
|
||
if state.x <> x then Lwd.set state_var { state with x }
|
||
in
|
||
let ( <-> ) = Ui.join_y and ( <|> ) = Ui.join_x in
|
||
match (hvisible, vvisible) with
|
||
| false, false -> body
|
||
| false, true ->
|
||
crop body <|> vscrollbar state_h bh state_y ~set:set_vscroll
|
||
| true, false ->
|
||
crop body <-> hscrollbar state_w bw state_x ~set:set_hscroll
|
||
| true, true ->
|
||
crop body
|
||
<|> vscrollbar state_h bh state_y ~set:set_vscroll
|
||
<-> (hscrollbar state_w bw state_x ~set:set_hscroll
|
||
<|> Ui.space scrollbar_width scrollbar_width)
|
||
in
|
||
(* Render final box *)
|
||
Lwd.map2 t (Lwd.get state_var) ~f:(fun ui size ->
|
||
measure_size (compose_bars ui size))
|
||
end
|