2982 lines
94 KiB
OCaml
2982 lines
94 KiB
OCaml
(*
|
||
|
||
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);
|
||
Logs.debug (fun m -> m "hello")
|
||
|
||
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" Git_af.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 ]
|
||
|
||
type mods = [ `Super | `Meta | `Ctrl | `Shift ] list
|
||
|
||
type mouse =
|
||
[ `Press of button | `Drag | `Release ] * (float * float) * mods
|
||
|
||
type paste = [ `Start | `End ]
|
||
type keyaction = [ `Press | `Release | `Repeat ]
|
||
|
||
(* stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *)
|
||
let string_of_code = function
|
||
| `Uchar ch ->
|
||
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; "\"" ]
|
||
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.2
|
||
let dark = gray 0.8
|
||
|
||
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 pp ppf t : unit =
|
||
F.(
|
||
fmt "%a" ppf
|
||
(record
|
||
[
|
||
field "r" (fun t -> t.r) F.float;
|
||
field "g" (fun t -> t.g) F.float;
|
||
field "b" (fun t -> t.b) F.float;
|
||
field "a" (fun t -> t.a) F.float;
|
||
])
|
||
t)
|
||
end
|
||
end
|
||
|
||
open NVG
|
||
|
||
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
|
||
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;
|
||
Box2.max 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.max b
|
||
|
||
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 empty =
|
||
{
|
||
size = None;
|
||
font = `None;
|
||
weight = `None;
|
||
italic = `None;
|
||
underline = `None;
|
||
}
|
||
|
||
let default =
|
||
ref
|
||
{
|
||
size = Some 20.;
|
||
font = `Sans;
|
||
weight = `Regular;
|
||
italic = `None;
|
||
underline = `None;
|
||
}
|
||
|
||
let size { size; _ } =
|
||
match (size, !default.size) with
|
||
| None, None -> 20.
|
||
| None, Some s | 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"
|
||
| _ -> ()
|
||
end
|
||
|
||
type t = { fg : Color.t; bg : Color.t; font : Font.t }
|
||
type attr = t
|
||
|
||
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 =
|
||
if a1 == empty then a2
|
||
else if a2 == empty then a1
|
||
else
|
||
{
|
||
a1 with
|
||
fg = Color.lerp a1.fg a2.fg ~a:0.5;
|
||
bg = Color.lerp a1.bg a2.bg ~a:0.5;
|
||
}
|
||
|
||
let fg c = { empty with fg = c }
|
||
let bg c = { empty with bg = 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
|
||
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
|
||
|
||
(* 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
|
||
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 "String %s" ppf s)
|
||
end
|
||
|
||
module A = Style
|
||
|
||
module I = struct
|
||
open Gg
|
||
|
||
type dim = p2
|
||
|
||
type t =
|
||
| Empty
|
||
| Segment of 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 rec size vg p = function
|
||
| Empty -> V2.zero
|
||
| Segment s ->
|
||
let NVG.Bounds.{ xmin; ymin; xmax; ymax } =
|
||
(NVG.Text.bounds vg ~x:(V2.x p) ~y:(V2.y p)
|
||
(Text.to_string s))
|
||
.box
|
||
in
|
||
V2.v (xmax -. xmin) (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
|
||
p2_max p1 p2
|
||
| Vcompose (t1, t2) ->
|
||
let p1 = size vg p t1 in
|
||
let p2 = size vg V2.(p + v 0. (y p1)) t2 in
|
||
p2_max p1 p2
|
||
| Zcompose (t1, t2) -> p2_max (size vg p t1) (size vg p t2)
|
||
| Hcrop (t, left, right) ->
|
||
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.(a ++ a0))
|
||
| 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)
|
||
|
||
let hcrop left right img = Hcrop (img, left, right)
|
||
let vcrop top bottom img = 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 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 ppf : t -> unit = function
|
||
| Empty -> F.(fmt "Empty" ppf)
|
||
| Segment v -> F.(fmt "Segment %a" ppf (parens Text.pp) v)
|
||
| Attr v ->
|
||
F.(fmt "Attr %a" ppf (pair (parens pp) (any "...")) v)
|
||
| Hcompose a ->
|
||
F.(fmt "Hcompose %a" ppf (pair (parens pp) (parens pp)) a)
|
||
| Vcompose a ->
|
||
F.(fmt "Vcompose %a" ppf (pair (parens pp) (parens pp)) a)
|
||
| Zcompose a ->
|
||
F.(fmt "Zcompose %a" ppf (pair (parens pp) (parens pp)) a)
|
||
| Hcrop (t, h, w) -> F.(fmt "Hcrop (%a,%f,%f)" ppf pp t h w)
|
||
| Vcrop (t, h, w) -> F.(fmt "Vcrop (%a,%f,%f)" ppf pp t h w)
|
||
| Void dim -> F.(fmt "Void %a" ppf (parens V2.pp) dim)
|
||
|
||
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 metrics = NVG.Text.metrics vg in
|
||
let twidth =
|
||
NVG.Text.text_w vg ~x:(V2.x p)
|
||
~y:(V2.y p +. metrics.ascender)
|
||
s
|
||
in
|
||
V2.(
|
||
p
|
||
+ v twidth
|
||
(P2.y p +. metrics.ascender +. metrics.descender
|
||
+. metrics.line_height))
|
||
|
||
and node vg attr p n : p2 =
|
||
let b' =
|
||
match n with
|
||
| Empty | Void _ -> p
|
||
| Segment text -> segment vg p text
|
||
| Attr (i, a0) ->
|
||
let p1 = node vg A.(attr ++ a0) p i in
|
||
(* TODO need to set that weird "draw under" thing here *)
|
||
if Style.(attr.fg) != a0.fg then
|
||
NVG.set_stroke_color vg ~color:Style.(attr.fg);
|
||
if Style.(attr.bg) != a0.bg then
|
||
NVG.set_fill_color vg ~color:Style.(attr.bg);
|
||
p1
|
||
| 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
|
||
p2_max p1 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
|
||
p2_max p1 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) -> node vg attr p i
|
||
| Vcrop (i, top, bottom) -> node vg attr p i
|
||
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
|
||
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;
|
||
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, x | x, Empty -> x
|
||
| _, Handle (0, _) -> s1
|
||
| Handle (0, _), _ -> s2
|
||
| 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
|
||
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 = int
|
||
type t2 = int
|
||
|
||
let default = 0
|
||
|
||
let pack = function
|
||
| `Negative -> 0
|
||
| `Neutral -> 1
|
||
| `Positive -> 2
|
||
|
||
let unpack = function
|
||
| 0 -> `Negative
|
||
| 1 -> `Neutral
|
||
| _ -> `Positive
|
||
|
||
let make ~h ~v = (pack h lsl 2) lor pack v
|
||
let h x = unpack (x lsr 2)
|
||
let v x = unpack (x land 3)
|
||
|
||
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)
|
||
|
||
let pair t1 t2 = (t1 lsl 4) lor t2
|
||
let p1 t = (t lsr 4) land 15
|
||
let p2 t = t land 15
|
||
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 -> int*)
|
||
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 ]
|
||
|
||
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
|
||
| `ASCII of char
|
||
| semantic_key ]
|
||
* Input.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_layout_spec ppf { w; h; sw; sh } =
|
||
Format.fprintf ppf "{ w = %f; h = %f; sw = %f; sh = %f }" w h sw
|
||
sh
|
||
|
||
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 t = {
|
||
w : float;
|
||
sw : float;
|
||
h : float;
|
||
sh : float;
|
||
mutable desc : desc;
|
||
focus : Focus.status;
|
||
mutable flags : flags;
|
||
mutable sensor_cache : (float * float * float * float) option;
|
||
mutable cache : cache;
|
||
}
|
||
|
||
and image = I.t
|
||
and cache = { vx : Interval.t; vy : Interval.t; image : image }
|
||
|
||
and desc =
|
||
| Atom of image
|
||
| Size_sensor of t * size_sensor
|
||
| Transient_sensor of t * frame_sensor
|
||
| Permanent_sensor of t * frame_sensor
|
||
| Resize of t * Gravity.t2 * A.t
|
||
| Mouse_handler of t * mouse_handler
|
||
| Focus_area of t * (key -> may_handle)
|
||
| Shift_area of t * float * float
|
||
| Event_filter of
|
||
t * ([ `Key of key | `Mouse of mouse ] -> may_handle)
|
||
| X of t * t
|
||
| Y of t * t
|
||
| Z of t * t
|
||
|
||
let layout_spec 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 cache : cache =
|
||
{ vx = Interval.zero; vy = Interval.zero; image = I.empty }
|
||
|
||
let empty : t =
|
||
{
|
||
w = 0.;
|
||
sw = 0.;
|
||
h = 0.;
|
||
sh = 0.;
|
||
flags = flags_none;
|
||
focus = Focus.empty;
|
||
desc = Atom I.empty;
|
||
sensor_cache = None;
|
||
cache;
|
||
}
|
||
|
||
let atom img : t =
|
||
{
|
||
w = 0.;
|
||
sw = 0.;
|
||
h = 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 =
|
||
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 ?(bg = A.empty) t : t =
|
||
let g = prepare_gravity (pad, crop) in
|
||
match ((w, t.w), (h, t.h), (sw, t.sw), (sh, t.sh)) with
|
||
| ( (Some w, _ | None, w),
|
||
(Some h, _ | None, h),
|
||
(Some sw, _ | None, sw),
|
||
(Some sh, _ | None, sh) ) ->
|
||
{ t with w; h; sw; sh; desc = Resize (t, g, bg) }
|
||
|
||
let resize_to ({ w; h; sw; sh } : layout_spec) ?pad ?crop
|
||
?(bg = A.empty) t : t =
|
||
let g = prepare_gravity (pad, crop) in
|
||
{ t with w; h; sw; sh; desc = Resize (t, g, bg) }
|
||
|
||
let event_filter ?focus f 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 b =
|
||
{
|
||
w = a.w +. b.w;
|
||
sw = a.sw +. b.sw;
|
||
h = max a.h b.h;
|
||
sh = max a.sh b.sh;
|
||
flags = a.flags lor b.flags;
|
||
focus = Focus.merge a.focus b.focus;
|
||
desc = X (a, b);
|
||
sensor_cache = None;
|
||
cache;
|
||
}
|
||
|
||
let join_y a b =
|
||
{
|
||
w = max a.w b.w;
|
||
sw = max a.sw b.sw;
|
||
h = a.h +. b.h;
|
||
sh = a.sh +. b.sh;
|
||
flags = a.flags lor b.flags;
|
||
focus = Focus.merge a.focus b.focus;
|
||
desc = Y (a, b);
|
||
sensor_cache = None;
|
||
cache;
|
||
}
|
||
|
||
let join_z a b =
|
||
{
|
||
w = max a.w b.w;
|
||
sw = max a.sw b.sw;
|
||
h = max a.h b.h;
|
||
sh = max a.sh b.sh;
|
||
flags = a.flags lor b.flags;
|
||
focus = Focus.merge a.focus b.focus;
|
||
desc = Z (a, b);
|
||
sensor_cache = None;
|
||
cache;
|
||
}
|
||
|
||
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 =
|
||
Format.fprintf ppf
|
||
"@[<hov>{@ w = %f;@ h = %f;@ sw = %f;@ sh = %f;@ desc = \
|
||
@[%a@];@ }@]"
|
||
t.w t.h t.sw t.sh pp_desc t.desc
|
||
|
||
and pp_desc ppf = function
|
||
| Atom _ -> Format.fprintf ppf "Atom _"
|
||
| 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, gravity, _bg) ->
|
||
Format.fprintf ppf "Resize (@[%a,@ %a,@ %a@])" pp desc
|
||
Gravity.pp (Gravity.p1 gravity) Gravity.pp
|
||
(Gravity.p2 gravity)
|
||
| Mouse_handler (n, _) ->
|
||
Format.fprintf ppf "Mouse_handler (@[%a,@ _@])" pp n
|
||
| Focus_area (n, _) ->
|
||
Format.fprintf ppf "Focus_area (@[%a,@ _@])" pp n
|
||
| Shift_area (n, _, _) ->
|
||
Format.fprintf ppf "Shift_area (@[%a,@ _@])" pp n
|
||
| Event_filter (n, _) ->
|
||
Format.fprintf ppf "Event_filter (@[%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 = {
|
||
mutable size : size;
|
||
mutable view : ui;
|
||
mutable mouse_grab : grab_function option;
|
||
}
|
||
|
||
let make () = { mouse_grab = None; size = P2.o; view = Ui.empty }
|
||
let size t = t.size
|
||
|
||
let solve_focus 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 _ -> Ui.iter aux ui
|
||
in
|
||
aux ui
|
||
|
||
let split ~a ~sa ~b ~sb total =
|
||
let stretch = sa +. sb in
|
||
let flex = total -. a -. b in
|
||
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)
|
||
|
||
let pack ~fixed ~stretch total g1 g2 =
|
||
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)
|
||
|
||
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 =
|
||
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, 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
|
||
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 update t size ui =
|
||
t.size <- size;
|
||
t.view <- ui;
|
||
update_sensors 0. 0. (P2.x size) (P2.y size) ui;
|
||
update_focus ui
|
||
|
||
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, _bg) ->
|
||
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
|
||
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 =
|
||
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 ->
|
||
{
|
||
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, a) ->
|
||
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 image =
|
||
if a.bg != Color.none then
|
||
I.(image </> char ~attr:a ' ' sw sh)
|
||
else 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
|
||
(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
|
||
try
|
||
aux ui;
|
||
false
|
||
with Acquired_focus -> 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
|
||
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, [ `Meta ]) ->
|
||
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, _) ->
|
||
if dispatch_focus st.view dir 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 () 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 = function
|
||
| `Key (`ASCII 'q', [ `Meta ]) as event -> (
|
||
match do_quit with
|
||
| Some u -> Lwt.wakeup u ()
|
||
| None -> ignore (Renderer.dispatch_event renderer event))
|
||
| #Ui.event as event ->
|
||
ignore (Renderer.dispatch_event renderer event)
|
||
| `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
|
||
|
||
let attr_menu_main = A.(bg Color.green ++ fg Color.black)
|
||
let attr_menu_sub = A.(bg Color.lightgreen ++ fg Color.black)
|
||
let attr_clickable = A.(bg Color.lightblue)
|
||
|
||
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)
|
||
~bg:A.(bg 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 = 1
|
||
|
||
type scroll_state = {
|
||
position : int;
|
||
bound : int;
|
||
visible : int;
|
||
total : int;
|
||
}
|
||
|
||
let default_scroll_state =
|
||
{ position = 0; bound = 0; visible = 0; total = 0 }
|
||
|
||
let vscroll_area ~state ~change t =
|
||
let visible = ref (-1) in
|
||
let total = ref (-1) in
|
||
let scroll state delta =
|
||
let position = state.position + delta in
|
||
let position = max 0 (min state.bound position) in
|
||
if position <> state.position then
|
||
change `Action { state with position };
|
||
`Handled
|
||
in
|
||
let focus_handler state = function
|
||
(*| `Arrow `Left , _ -> scroll (-scroll_step) 0*)
|
||
(*| `Arrow `Right, _ -> scroll (+scroll_step) 0*)
|
||
| `Arrow `Up, [] -> scroll state (-scroll_step)
|
||
| `Arrow `Down, [] -> scroll state (+scroll_step)
|
||
| `Page `Up, [] -> scroll state (-scroll_step * 8)
|
||
| `Page `Down, [] -> scroll state (+scroll_step * 8)
|
||
| _ -> `Unhandled
|
||
in
|
||
let scroll_handler state ~x:_ ~y:_ = function
|
||
| `Scroll `Up -> scroll state (-scroll_step)
|
||
| `Scroll `Down -> scroll state (+scroll_step)
|
||
| _ -> `Unhandled
|
||
in
|
||
Lwd.map2 t state ~f:(fun t state ->
|
||
t
|
||
|> Ui.shift_area 0 state.position
|
||
|> Ui.resize ~h:0 ~sh:1
|
||
|> Ui.size_sensor (fun ~w:_ ~h ->
|
||
let tchange =
|
||
if !total <> (Ui.layout_spec t).Ui.h then (
|
||
total := (Ui.layout_spec t).Ui.h;
|
||
true)
|
||
else false
|
||
in
|
||
let vchange =
|
||
if !visible <> h then (
|
||
visible := h;
|
||
true)
|
||
else false
|
||
in
|
||
if tchange || vchange then
|
||
change `Content
|
||
{
|
||
state with
|
||
visible = !visible;
|
||
total = !total;
|
||
bound = max 0 (!total - !visible);
|
||
})
|
||
|> Ui.mouse_area (scroll_handler state)
|
||
|> Ui.keyboard_area (focus_handler state))
|
||
|
||
let scroll_area ?(offset = (0, 0)) t =
|
||
let offset = Lwd.var offset in
|
||
let scroll d_x d_y =
|
||
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:attr_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:attr_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:attr_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 : int; max : int }
|
||
| Re_split of { pos : int; max : int; at : int }
|
||
|
||
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
|
||
~bg:Notty.A.(bg 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: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 - 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
|
||
~bg:Notty.A.(bg 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 sub' str p l =
|
||
if p = 0 && l = String.length str then str else String.sub str p l
|
||
|
||
let edit_field ?(focus = Focus.make ()) state ~on_change ~on_submit
|
||
=
|
||
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 = attr_clickable in
|
||
let len = String.length text in
|
||
(if pos >= len then [ I.string attr text ]
|
||
else [ I.string attr (sub' text 0 pos) ])
|
||
@
|
||
if pos < String.length text then
|
||
[
|
||
I.string A.(bg lightred) (sub' text pos 1);
|
||
I.string attr (sub' text (pos + 1) (len - pos - 1));
|
||
]
|
||
else [ I.string A.(bg lightred) " " ]
|
||
else
|
||
[
|
||
I.string
|
||
A.(st underline)
|
||
(if text = "" then " " else text);
|
||
]
|
||
in
|
||
let handler = function
|
||
| `ASCII 'U', [ `Ctrl ] ->
|
||
on_change ("", 0);
|
||
`Handled (* clear *)
|
||
| `Escape, [] ->
|
||
Focus.release focus_h;
|
||
`Handled
|
||
| `ASCII k, _ ->
|
||
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);
|
||
`Handled
|
||
| `Backspace, _ ->
|
||
let text =
|
||
if pos > 0 then
|
||
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
|
||
else text
|
||
in
|
||
let pos = max 0 (pos - 1) in
|
||
on_change (text, pos);
|
||
`Handled
|
||
| `Enter, _ ->
|
||
on_submit (text, pos);
|
||
`Handled
|
||
| `Arrow `Left, [] ->
|
||
let pos = min (String.length text) pos in
|
||
if pos > 0 then (
|
||
on_change (text, pos - 1);
|
||
`Handled)
|
||
else `Unhandled
|
||
| `Arrow `Right, [] ->
|
||
let pos = pos + 1 in
|
||
if pos <= String.length text then (
|
||
on_change (text, pos);
|
||
`Handled)
|
||
else `Unhandled
|
||
| _ -> `Unhandled
|
||
in
|
||
Ui.keyboard_area ~focus handler content
|
||
in
|
||
let node =
|
||
Lwd.map2 ~f:(update focus) (Focus.status focus) state
|
||
in
|
||
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)
|
||
|
||
(** 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.(st underline) 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 -> empty_lwd
|
||
in
|
||
(* pad summary with a "> " when it's opened *)
|
||
let summary =
|
||
Lwd.get opened >>= fun op ->
|
||
summary >|= fun s ->
|
||
Ui.hcat
|
||
[
|
||
string ~attr:attr_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 > 1
|
||
|| spec_fold.Ui.h > 0
|
||
&& spec_sum.Ui.w + spec_fold.Ui.w > 60
|
||
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)
|
||
|> Lwd_utils.pack Ui.pack_y
|
||
|
||
(** 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 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.mouse_area
|
||
(fun ~x:_ ~y:_ _ ->
|
||
f ();
|
||
`Handled)
|
||
ui
|
||
|
||
(** A clickable button that calls [f] when clicked, labelled with a string. *)
|
||
let button ?(attr = attr_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.(st underline)
|
||
path
|
||
(fun () -> on_select path)
|
||
with e ->
|
||
Lwd.return
|
||
@@ Ui.vcat
|
||
[
|
||
printf ~attr:A.(bg 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:attr_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 : int; h : int; x : int; y : int }
|
||
|
||
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 decr_if x cond = if cond then x - 1 else x
|
||
let scrollbar_bg = Notty.A.gray 4
|
||
let scrollbar_fg = Notty.A.gray 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 Notty.(I.char (A.bg color) ' ' size 1)
|
||
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 Notty.(I.char (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:1 ~sh:1 ~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 1 1)
|
||
in
|
||
(* Render final box *)
|
||
Lwd.map2 t (Lwd.get state_var) ~f:(fun ui size ->
|
||
measure_size (compose_bars ui size)) *)
|
||
end
|