1811 lines
55 KiB
OCaml
1811 lines
55 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]
|
|
|
|
|
|
|
|
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 NVG = Graphv_webgl
|
|
|
|
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 log_buf = Buffer.create 4096
|
|
|
|
let console_report _src level ~over k msgf =
|
|
let k _ =
|
|
let s = flush () in
|
|
console level s;
|
|
Buffer.add_string log_buf 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 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 = 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 "main" >>= 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/boot"
|
|
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 Key = struct
|
|
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 keyaction = [ `Press | `Release | `Repeat ]
|
|
|
|
type keystate = {
|
|
ctrl : bool;
|
|
meta : bool;
|
|
shift : bool;
|
|
super : bool;
|
|
code : code;
|
|
}
|
|
|
|
module KeyS = struct
|
|
type t = keystate
|
|
|
|
let compare = compare
|
|
end
|
|
|
|
module Bind = struct
|
|
(* parts stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *)
|
|
module S = Zed_input.Make (KeyS)
|
|
|
|
type 'a t = 'a list S.t
|
|
type 'a resolver = 'a list S.resolver
|
|
type 'a result = 'a list S.result
|
|
|
|
type 'a state = {
|
|
mutable bindings : 'a t;
|
|
mutable state : 'a result;
|
|
mutable last_keyseq : keystate list;
|
|
mutable last_actions : 'a list;
|
|
}
|
|
|
|
type mods = Ctrl | Meta | Super | Shift
|
|
type key = C of char | U of code
|
|
|
|
let keystate_of_mods ks m =
|
|
List.fold_left
|
|
(fun ks m ->
|
|
match m with
|
|
| Meta -> { ks with meta = true }
|
|
| Ctrl -> { ks with ctrl = true }
|
|
| Super -> { ks with super = true }
|
|
| Shift -> { ks with shift = true })
|
|
ks m
|
|
|
|
let add events action bindings =
|
|
let events =
|
|
List.map
|
|
(fun (m, k) ->
|
|
keystate_of_mods
|
|
{
|
|
meta = false;
|
|
ctrl = false;
|
|
super = false;
|
|
shift = false;
|
|
code =
|
|
(match k with
|
|
| C c -> `Uchar (Uchar.of_char c)
|
|
| U c -> c);
|
|
}
|
|
m)
|
|
events
|
|
in
|
|
S.add events action bindings
|
|
|
|
let default_resolver b = S.resolver [ S.pack (fun x -> x) b ]
|
|
|
|
let get_resolver result default =
|
|
match result with S.Continue r -> r | _ -> default
|
|
|
|
let init bindings =
|
|
{
|
|
bindings;
|
|
state = S.Rejected;
|
|
last_keyseq = [];
|
|
last_actions = [];
|
|
}
|
|
|
|
let resolve = S.resolve
|
|
let empty = S.empty
|
|
|
|
type action = Custom of (unit -> unit) | Zed of Zed_edit.action
|
|
|
|
let resolve_events (state : 'a state) events =
|
|
List.flatten
|
|
(List.filter_map
|
|
(fun e ->
|
|
match e with
|
|
| `Key (`Press, (k : keystate)) -> (
|
|
(match state.state with
|
|
| Continue _ -> ()
|
|
| _ -> state.last_keyseq <- []);
|
|
state.state <-
|
|
resolve k
|
|
(get_resolver state.state
|
|
(default_resolver state.bindings));
|
|
state.last_keyseq <- k :: state.last_keyseq;
|
|
match state.state with
|
|
| Accepted a ->
|
|
state.last_actions <- a;
|
|
Some a
|
|
| Rejected ->
|
|
state.last_actions <- [];
|
|
None
|
|
| _ -> None)
|
|
| _ -> None)
|
|
events)
|
|
|
|
let actions_of_events (state : action state) events =
|
|
List.flatten
|
|
(List.filter_map
|
|
(fun e ->
|
|
match e with
|
|
| `Key (`Press, (k : keystate)) -> (
|
|
(match state.state with
|
|
| Continue _ -> ()
|
|
| _ -> state.last_keyseq <- []);
|
|
state.state <-
|
|
resolve k
|
|
(get_resolver state.state
|
|
(default_resolver state.bindings));
|
|
state.last_keyseq <- k :: state.last_keyseq;
|
|
match state.state with
|
|
| Accepted a ->
|
|
state.last_actions <- a;
|
|
Some a
|
|
| Rejected ->
|
|
state.last_actions <- [];
|
|
None
|
|
| _ -> None)
|
|
| _ -> None)
|
|
events)
|
|
|
|
let process bindstate events =
|
|
List.iter
|
|
(function Custom f -> f () | Zed _ -> ())
|
|
(actions_of_events bindstate events)
|
|
end
|
|
|
|
(* 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; "\"" ]
|
|
|
|
let to_string key =
|
|
Printf.sprintf
|
|
"{ control = %B; meta = %B; shift = %B; super = %B; code = %s }"
|
|
key.ctrl key.meta key.shift key.super
|
|
(string_of_code key.code)
|
|
|
|
let to_string_compact key =
|
|
let buffer = Buffer.create 32 in
|
|
if key.ctrl then Buffer.add_string buffer "Ctrl-";
|
|
if key.meta then Buffer.add_string buffer "Meta-";
|
|
if key.shift then Buffer.add_string buffer "Shift-";
|
|
if key.super then Buffer.add_string buffer "Super-";
|
|
(match key.code with
|
|
| `Uchar ch ->
|
|
let code = Uchar.to_int ch in
|
|
if Uchar.is_char ch then
|
|
match Uchar.to_char ch with
|
|
| ( 'a' .. 'z'
|
|
| 'A' .. 'Z'
|
|
| '0' .. '9'
|
|
| '_' | '(' | ')' | '[' | ']' | '{' | '}' | '#' | '~'
|
|
| '&' | '$' | '*' | '%' | '!' | '?' | ',' | ';' | ':'
|
|
| '/' | '\\' | '.' | '@' | '=' | '+' | '-' ) as ch ->
|
|
Buffer.add_char buffer ch
|
|
| ' ' -> Buffer.add_string buffer "space"
|
|
| _ -> Printf.bprintf buffer "U+%02x" code
|
|
else if code <= 0xffff then
|
|
Printf.bprintf buffer "U+%04x" code
|
|
else Printf.bprintf buffer "U+%06x" code
|
|
| `Page `Down -> Buffer.add_string buffer "pgup"
|
|
| `Page `Up -> Buffer.add_string buffer "pgdn"
|
|
| code ->
|
|
Buffer.add_string buffer
|
|
(String.lowercase_ascii (string_of_code code)));
|
|
Buffer.contents buffer
|
|
end
|
|
|
|
module Event = struct
|
|
open Gg
|
|
|
|
type mouse = V2.t
|
|
type keystate = Key.keystate
|
|
type keyaction = Key.keyaction
|
|
|
|
type t =
|
|
[ `Key of keyaction * keystate
|
|
| `Mouse of mouse
|
|
| `Quit
|
|
| `Fullscreen of bool
|
|
| `Unknown of string ]
|
|
|
|
type events = t list
|
|
|
|
let to_string : t -> string = function
|
|
| `Key (x, k) ->
|
|
"`Key "
|
|
^ (match x with
|
|
| `Press -> "`Press "
|
|
| `Release -> "`Release "
|
|
| `Repeat -> "`Repeat ")
|
|
^ Key.to_string k
|
|
| `Mouse m -> F.str "`Mouse %a" V2.pp m
|
|
| `Quit -> "`Quit"
|
|
| `Fullscreen b -> F.str "`Fullscreen %b" b
|
|
| `Unknown s -> F.str "`Unknown %s" s
|
|
|
|
let handle_keyevents (el : events) f = List.iter f el
|
|
let empty = `Unknown "empty"
|
|
end
|
|
|
|
module Event_js = struct
|
|
include Event
|
|
open Js_of_ocaml
|
|
|
|
type t = Dom_html.Keyboard_code.t
|
|
|
|
let decode_single_uchar (str : string) =
|
|
(* yea we return None if there is more than one Uchar bitch **)
|
|
let rec decode dec (d : Uchar.t option) : Uchar.t option =
|
|
match Uutf.decode dec with
|
|
| `Malformed b ->
|
|
F.epr "Backend.Key.decode_fst_uchar `Malformed \"%s\"@."
|
|
(String.escaped b);
|
|
None
|
|
| `Await -> decode dec d
|
|
| `End -> d
|
|
| `Uchar u ->
|
|
if Option.is_none d then decode dec (Some u) else None
|
|
in
|
|
decode
|
|
(Uutf.decoder
|
|
~nln:(`Readline (Uchar.of_int 0x000A))
|
|
(`String str))
|
|
None
|
|
|
|
let of_jskey = function
|
|
| "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 decode_single_uchar s with
|
|
| Some s -> `Uchar s
|
|
| None -> `Unknown s)
|
|
|
|
let evt_of_jskey (p : Key.keyaction)
|
|
(evt : Dom_html.keyboardEvent Js.t) : Event.t =
|
|
match Js.Optdef.to_option evt##.key with
|
|
| Some s ->
|
|
`Key
|
|
( p,
|
|
Key.
|
|
{
|
|
meta = Js.to_bool evt##.altKey;
|
|
shift = Js.to_bool evt##.shiftKey;
|
|
ctrl = Js.to_bool evt##.ctrlKey;
|
|
super = Js.to_bool evt##.metaKey;
|
|
code = of_jskey (Js.to_string s);
|
|
} )
|
|
| None -> `Unknown "keypress .key is None?"
|
|
end
|
|
|
|
module Panel = struct
|
|
open Gg
|
|
open NVG
|
|
|
|
(* current window state to be passed to window renderer *)
|
|
type state = {
|
|
box : box2;
|
|
(* This is cannonically box within which the next element should draw *)
|
|
renderer : NVG.t;
|
|
}
|
|
|
|
(* the box2 here is cannonically the place the returner drew
|
|
(the Wall.image extents) *)
|
|
type pane = state -> state * box2
|
|
type actor = (Event.t -> P2.t) ref
|
|
|
|
let pane_empty s = (s, Box2.of_pts (Box2.o s.box) (Box2.o s.box))
|
|
|
|
let on_failure ~cleanup result =
|
|
(match result with Ok _ -> () | Error _ -> cleanup ());
|
|
result
|
|
|
|
let draw_pane vg pane width height =
|
|
let _, _ =
|
|
pane
|
|
{
|
|
box = Box2.v (P2.v 0. 0.) (P2.v width height);
|
|
renderer = vg;
|
|
}
|
|
in
|
|
Ok ()
|
|
|
|
let gray ?(a = 1.0) v = Color.rgbaf ~r:v ~g:v ~b:v ~a
|
|
|
|
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 gray a = Color.rgbf ~r:a ~g:a ~b:a
|
|
|
|
let empty =
|
|
{
|
|
fg = Color.transparent;
|
|
bg = Color.transparent;
|
|
font = Font.empty;
|
|
}
|
|
|
|
let light = { empty with fg = gray 0.2 }
|
|
let dark = { empty with fg = gray 0.8 }
|
|
let equal = ( == )
|
|
|
|
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 fg = { empty with fg }
|
|
let bg bg = { empty with bg }
|
|
|
|
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
|
|
type t = {
|
|
t : Gg.size1;
|
|
b : Gg.size1;
|
|
l : Gg.size1;
|
|
r : Gg.size1;
|
|
}
|
|
|
|
let empty =
|
|
{
|
|
t = Gg.Size1.zero;
|
|
b = Gg.Size1.zero;
|
|
l = Gg.Size1.zero;
|
|
r = Gg.Size1.zero;
|
|
}
|
|
|
|
let all v = { t = v; b = v; l = v; r = v }
|
|
end
|
|
|
|
module Ui = struct
|
|
(* Tree-like structure of Ui elements, from the entire display down to individual glyphs. *)
|
|
(* i think this is gonna end up being a binary tree?? *)
|
|
|
|
(* TODO make sure this is LCRS: https://en.wikipedia.org/wiki/Left-child_right-sibling_binary_tree *)
|
|
|
|
open Gg
|
|
|
|
type t =
|
|
[ `Atom of atom
|
|
| `Attr of attr * node
|
|
| `Join of dir * node * node ]
|
|
|
|
and node = { mutable parent : parent; mutable t : t; n : int }
|
|
and parent = [ `Left of node | `Right of node | `None ]
|
|
and cursor = { root : node; mutable sel : node }
|
|
|
|
and atom =
|
|
[ `Image of image
|
|
| `Uchar of Uchar.t
|
|
| `Boundary of boundary
|
|
| `Hint of [ `Line | `Other ]
|
|
| `Empty ]
|
|
|
|
and attr =
|
|
[ `Style of style
|
|
| `Pad of Pad.t
|
|
| `Handler of handler
|
|
| `Draw of draw ]
|
|
|
|
and p = P2.t
|
|
and dir = [ `X | `Y | `Z ]
|
|
and image = NVG.Image.image
|
|
and boundary = [ `Char | `Word | `Phrase | `Line | `Page | `Text ]
|
|
and style = Style.t
|
|
and handler = node -> Event.t -> Event.t option
|
|
and draw_context = { vg : NVG.t; style : Style.t }
|
|
and draw = draw_context -> p -> p
|
|
|
|
let node_count = ref 0
|
|
|
|
let node_n () =
|
|
node_count := !node_count + 1;
|
|
!node_count - 1
|
|
|
|
let set_parent_on_children n : node =
|
|
(match n.t with
|
|
| `Atom _ -> ()
|
|
| `Attr (_, a) -> a.parent <- `Left n
|
|
| `Join (_, a, b) ->
|
|
a.parent <- `Left n;
|
|
b.parent <- `Right n);
|
|
n
|
|
|
|
let sub (n : node) : node =
|
|
match n.t with
|
|
| `Atom _ -> n
|
|
| `Attr (_, n) -> n
|
|
| `Join (_, a, _) -> a
|
|
|
|
let super (n : node) : node =
|
|
match n.parent with `Left n' | `Right n' -> n' | `None -> n
|
|
|
|
let set_children_on_parent n =
|
|
match n.parent with
|
|
| `Left ({ t = `Attr (a, _); _ } as s)
|
|
| `Right ({ t = `Attr (a, _); _ } as s) ->
|
|
s.t <- `Attr (a, n);
|
|
n
|
|
| `Left ({ t = `Join (d, _, b); _ } as s) ->
|
|
s.t <- `Join (d, n, b);
|
|
n
|
|
| `Right ({ t = `Join (d, a, _); _ } as s) ->
|
|
s.t <- `Join (d, a, n);
|
|
n
|
|
| _ -> n
|
|
|
|
let option_of_parent = function
|
|
| `None -> None
|
|
| `Left a | `Right a -> Some a
|
|
|
|
let node (t : t) =
|
|
set_parent_on_children { parent = `None; t; n = node_n () }
|
|
|
|
let atom (a : atom) = node (`Atom a)
|
|
let attr (a : attr) (child : node) = node (`Attr (a, child))
|
|
let join (d : dir) (a : node) (b : node) = node (`Join (d, a, b))
|
|
let empty_image = V2.zero
|
|
let empty_node () = node (`Atom `Empty)
|
|
let style (s : Style.t) (n : node) = node (`Attr (`Style s, n))
|
|
let pad v n = attr (`Pad (Pad.all v)) n
|
|
|
|
let rec node_up_ (d : [ `Left | `Right ]) n' =
|
|
match (d, n'.parent) with
|
|
| _, `None -> None
|
|
| ( _,
|
|
( `Left ({ t = `Attr _; _ } as p)
|
|
| `Right ({ t = `Attr _; _ } as p) ) ) ->
|
|
node_up_ d p
|
|
| `Right, `Right ({ t = `Join _; _ } as p)
|
|
| `Left, `Left ({ t = `Join _; _ } as p) ->
|
|
node_up_ d p
|
|
| `Left, `Right { t = `Join (_, l, _); _ } -> Some l
|
|
| `Right, `Left { t = `Join (_, _, r); _ } -> Some r
|
|
| _, (`Left { t = `Atom _; _ } | `Right { t = `Atom _; _ }) ->
|
|
assert false
|
|
|
|
let node_next_ (d : [ `Left | `Right ]) (n : node) =
|
|
match (d, n.t) with
|
|
| _, `Atom _ -> node_up_ d n
|
|
| _, `Attr (_, n') -> Some n'
|
|
| `Right, `Join (_, _, r) -> Some r
|
|
| `Left, `Join (_, l, _) -> Some l
|
|
|
|
let rec search_preorder (f : node -> 'a option) (n : node) :
|
|
'a option =
|
|
match f n with
|
|
| None -> (
|
|
match node_next_ `Left n with
|
|
| Some n -> search_preorder f n
|
|
| None -> None)
|
|
| x -> x
|
|
|
|
let rec search_reverse_preorder (f : node -> 'a option) (n : node)
|
|
: 'a option =
|
|
match f n with
|
|
| None -> (
|
|
match node_next_ `Right n with
|
|
| Some n -> search_reverse_preorder f n
|
|
| None -> None)
|
|
| x -> x
|
|
|
|
let replace_parents_child parent n : node =
|
|
match parent with
|
|
| `Left ({ t = `Attr (a, _); _ } as p)
|
|
| `Right ({ t = `Attr (a, _); _ } as p) ->
|
|
p.t <- `Attr (a, n);
|
|
n
|
|
| `Left ({ t = `Join (d, _, r); _ } as p) ->
|
|
p.t <- `Join (d, n, r);
|
|
n
|
|
| `Right ({ t = `Join (d, l, _); _ } as p) ->
|
|
p.t <- `Join (d, l, n);
|
|
n
|
|
| _ -> n
|
|
|
|
let rec tree_iter f n i =
|
|
if i <> 0 then tree_iter f (f n) (i - 1) else f n
|
|
|
|
let search_forward f (n : node) = search_preorder f n
|
|
let search_backward f (n : node) = search_reverse_preorder f n
|
|
|
|
let is_atom_uchar = function
|
|
| { t = `Atom (`Uchar _); _ } as n -> Some n
|
|
| _ -> None
|
|
|
|
let tree_uchar_fwd n =
|
|
Option.value (search_forward is_atom_uchar n) ~default:n
|
|
|
|
let tree_uchar_back n =
|
|
Option.value (search_backward is_atom_uchar n) ~default:n
|
|
|
|
let is_boundary b n =
|
|
match (b, n.t) with
|
|
| `Char, `Atom (`Uchar _)
|
|
| `Word, `Atom (`Boundary `Word)
|
|
| `Phrase, `Atom (`Boundary `Phrase)
|
|
| `Line, `Atom (`Boundary `Line)
|
|
| `Page, `Atom (`Boundary `Page) ->
|
|
Some n
|
|
| _ -> None
|
|
|
|
let search_back_opt (f : node -> node option) (n : node option) =
|
|
Option.bind n (search_backward f)
|
|
|
|
let search_back_uchar_opt = search_back_opt is_atom_uchar
|
|
|
|
let rec traverse_nodes ~(f : node -> node option) (n : node) :
|
|
unit =
|
|
match f n with
|
|
| Some { t = `Atom _; _ } -> ()
|
|
| Some { t = `Attr (_, n'); _ } -> traverse_nodes ~f n'
|
|
| Some { t = `Join (_, a, b); _ } ->
|
|
traverse_nodes ~f a;
|
|
traverse_nodes ~f b
|
|
| None -> ()
|
|
|
|
let insert_join_l (d : dir) (n : node) (n' : node) : node =
|
|
let p = n.parent in
|
|
let n'' = join d n' n in
|
|
n''.parent <- p;
|
|
set_children_on_parent n''
|
|
|
|
let remove_join_l (n : node) : node =
|
|
match n.parent with
|
|
| `Left ({ t = `Attr (_, n'); _ } as s)
|
|
| `Right ({ t = `Attr (_, n'); _ } as s)
|
|
| `Left ({ t = `Join (_, _, n'); _ } as s) ->
|
|
s.t <- n'.t;
|
|
n'
|
|
| _ -> n
|
|
|
|
let kill_backward_char (n : node) : node option =
|
|
search_forward is_atom_uchar
|
|
(replace_parents_child (super (tree_uchar_back n)).parent n)
|
|
|
|
let insert_attr (a : attr) (n : node) : node =
|
|
let p = n.parent in
|
|
let n' = node (`Attr (a, n)) in
|
|
n'.parent <- p;
|
|
set_children_on_parent n'
|
|
|
|
let remove_attr (n : node) : node =
|
|
match n.t with
|
|
| `Attr (_, n') ->
|
|
(match n.parent with
|
|
| `Left ({ t = `Join (d, _, b); _ } as p) ->
|
|
p.t <- `Join (d, n', b);
|
|
ignore (set_parent_on_children p)
|
|
| `Right ({ t = `Join (d, a, _); _ } as p) ->
|
|
p.t <- `Join (d, a, n');
|
|
ignore (set_parent_on_children p)
|
|
| `Left ({ t = `Attr (a, _); _ } as p)
|
|
| `Right ({ t = `Attr (a, _); _ } as p) ->
|
|
p.t <- `Attr (a, n');
|
|
ignore (set_parent_on_children p)
|
|
| _ -> ());
|
|
n'
|
|
| _ -> assert false
|
|
|
|
let join_x = join `X
|
|
let join_y = join `Y
|
|
let join_z = join `Z
|
|
let ( ^^ ) = join_x
|
|
let ( ^/^ ) = join_y
|
|
let ( ^*^ ) = join_z
|
|
|
|
let append_ d (l : node -> node) (a : node) : node -> node =
|
|
fun n -> l (join d a n)
|
|
|
|
let empty_append = Fun.id
|
|
let append_x = append_ `X
|
|
let append_y = append_ `Y
|
|
let append_z = append_ `Z
|
|
|
|
module Pp = struct
|
|
let pp_uchar ppf v =
|
|
if Uchar.is_char v then Fmt.pf ppf "'%c'" (Uchar.to_char v)
|
|
else Fmt.Dump.uchar ppf v
|
|
|
|
let pp_boundary ppf v =
|
|
F.any
|
|
(match v with
|
|
| `Char -> "`Char"
|
|
| `Word -> "`Word"
|
|
| `Phrase -> "`Phrase"
|
|
| `Line -> "`Line"
|
|
| `Page -> "`Page"
|
|
| `Text ->
|
|
"`Text"
|
|
(* text is like a file (unicode calls it End Of Text) *))
|
|
ppf ()
|
|
|
|
let pp_atom ppf v =
|
|
let open Fmt in
|
|
(match v with
|
|
| `Image _ -> any "`Image"
|
|
| `Uchar c -> any "`Uchar " ++ const pp_uchar c
|
|
| `Boundary b -> any "`Boundary " ++ const pp_boundary b
|
|
| `Hint h ->
|
|
any "`Hint "
|
|
++ any
|
|
(match h with
|
|
| `Line -> "`Line"
|
|
| `Other -> "`Other")
|
|
| `Empty -> any "`Empty")
|
|
ppf ()
|
|
|
|
let pp_attr ppf v =
|
|
let open Fmt in
|
|
(any
|
|
(match v with
|
|
| `Style _ -> "`Style ..."
|
|
| `Pad _ -> "`Pad ..."
|
|
| `Shift _ -> "`Shift ..."
|
|
| `Cursor -> "`Cursor"
|
|
| `Handler _ -> "`Handler ..."
|
|
| `Draw _ -> "`Draw ..."))
|
|
ppf ()
|
|
|
|
let pp_dir ppf v =
|
|
F.pf ppf "%s"
|
|
(match v with `X -> "`X" | `Y -> "`Y" | `Z -> "`Z")
|
|
|
|
let pp_node_n ppf v = F.(pf ppf "%a" int v.n)
|
|
|
|
let rec _pp_t child ppf v =
|
|
let open Fmt in
|
|
match v with
|
|
| `Atom x -> pf ppf "`Atom %a" pp_atom x
|
|
| `Attr (a, n) ->
|
|
pf ppf "`Attr %a"
|
|
(parens (const pp_attr a ++ comma ++ const child n))
|
|
()
|
|
| `Join (d, a, b) ->
|
|
pf ppf "`Join %a"
|
|
(parens
|
|
(const pp_dir d ++ comma ++ const child a ++ comma
|
|
++ const child b))
|
|
()
|
|
|
|
and _pp_parent ppf v =
|
|
let open Fmt in
|
|
match v with
|
|
| `None -> pf ppf "`None"
|
|
| `Left n -> pf ppf "`Left %a" pp_node_n n
|
|
| `Right n -> pf ppf "`Right %a" pp_node_n n
|
|
|
|
and _pp_node child ppf v =
|
|
let open Fmt in
|
|
pf ppf "@[<hov>%a@]"
|
|
(braces
|
|
(record
|
|
[
|
|
field "n" (fun v -> v.n) int;
|
|
field "t" (fun v -> v.t) (_pp_t child);
|
|
field "parent" (fun v -> v.parent) _pp_parent;
|
|
]))
|
|
v
|
|
|
|
and pp_node_n_record =
|
|
F.(
|
|
braces
|
|
(record ~sep:semi
|
|
[ field "n" Fun.id pp_node_n; any "..." ]))
|
|
|
|
and pp_node ppf = _pp_node pp_node_n ppf
|
|
and pp_dump_node ppf = _pp_node pp_dump_node ppf
|
|
|
|
let pp_t ppf = F.pf ppf "@[<hov>%a@]" (_pp_t pp_node_n_record)
|
|
|
|
let pp_n ppf n =
|
|
F.pf ppf "@[<h>%a: %a@]" pp_node_n n (_pp_t pp_node_n) n.t
|
|
|
|
let rec pp_node_structure ppf v =
|
|
F.(
|
|
const int v.n
|
|
++ parens
|
|
(concat ~sep:comma
|
|
(match v.t with
|
|
| `Atom a -> [ const pp_atom a ]
|
|
| `Attr (a, n) ->
|
|
[ const pp_attr a; const pp_node_structure n ]
|
|
| `Join (d, l, r) ->
|
|
[
|
|
const pp_dir d;
|
|
const pp_node_structure l;
|
|
const pp_node_structure r;
|
|
])))
|
|
ppf ()
|
|
end
|
|
|
|
open Pp
|
|
|
|
module Text = struct
|
|
let rec decode dec (l : 'a) :
|
|
'a * [< `Await | `End | `Uchar of Uchar.t ] =
|
|
match Uutf.decode dec with
|
|
| `Malformed b ->
|
|
F.epr "Text.dec (Uutf.decode uudec)=`Malformed \"%s\"@."
|
|
(String.escaped b);
|
|
decode dec (append_x l (of_string (String.escaped b)))
|
|
| (`Await | `End | `Uchar _) as s -> (l, s)
|
|
|
|
and _of_string dec l =
|
|
match decode dec l with
|
|
| l, `End -> l (atom (`Boundary `Text))
|
|
| l, `Uchar c -> _of_string dec (append_x l (atom (`Uchar c)))
|
|
| l, _ -> _of_string dec l
|
|
|
|
and of_string str =
|
|
_of_string
|
|
(Uutf.decoder
|
|
~nln:(`Readline (Uchar.of_int 0x000A))
|
|
(`String str))
|
|
empty_append
|
|
|
|
and _lines u d ly (lx, s) =
|
|
match Uuseg.add u s with
|
|
| `Boundary when Uuseg.mandatory u ->
|
|
_lines u d
|
|
(append_y ly (lx (atom (`Boundary `Line))))
|
|
(empty_append, `Await)
|
|
| `Boundary ->
|
|
_lines u d ly (append_x lx (atom (`Hint `Line)), `Await)
|
|
| `End -> ly (lx (atom (`Boundary `Text)))
|
|
| `Await -> _lines u d ly (decode d lx)
|
|
| `Uchar c ->
|
|
_lines u d ly (append_x lx (atom (`Uchar c)), `Await)
|
|
|
|
let lines str =
|
|
_lines
|
|
(Uuseg.create `Line_break)
|
|
(Uutf.decoder
|
|
~nln:(`Readline (Uchar.of_int 0x000A))
|
|
(`String str))
|
|
empty_append (empty_append, `Await)
|
|
|
|
let text = of_string
|
|
let nl = atom (`Boundary `Line)
|
|
end
|
|
|
|
module Draw = struct
|
|
open NVG
|
|
|
|
type d = [ `X | `Y | `Z ]
|
|
type t = draw_context
|
|
|
|
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 uchar vg t (uc : Uchar.t) : P2.t =
|
|
let module Buffer = Stdlib.Buffer in
|
|
let b = Stdlib.Buffer.create 1 in
|
|
let enc = Uutf.encoder `UTF_8 (`Buffer b) in
|
|
let rec encode c =
|
|
match Uutf.encode enc c with
|
|
| `Ok -> ()
|
|
| `Partial -> encode `Await
|
|
in
|
|
encode (`Uchar uc);
|
|
encode `End;
|
|
let text = Bytes.to_string (Buffer.to_bytes b) in
|
|
let open NVG in
|
|
let bounds = Text.bounds vg ~x:(V2.x t) ~y:(V2.y t) text in
|
|
let metrics = Text.metrics vg in
|
|
let x, y = (V2.x t, V2.y t +. metrics.ascender) in
|
|
Text.text vg ~x ~y text;
|
|
P2.v
|
|
(P2.x t +. bounds.advance)
|
|
(P2.y t +. metrics.ascender +. metrics.descender
|
|
+. metrics.line_height)
|
|
|
|
let rec atom vg b (a : atom) : P2.t =
|
|
let vg = vg.vg in
|
|
match a with
|
|
| `Image image ->
|
|
let wi, hi = Image.size vg image in
|
|
let w, h = (float wi, float hi) in
|
|
Path.begin_ vg;
|
|
Path.rect vg ~x:(P2.x b) ~y:(P2.y b) ~w ~h;
|
|
let img_paint =
|
|
Paint.image_pattern vg ~cx:(P2.x b) ~cy:(P2.y b) ~w ~h
|
|
~angle:0.0 ~image ~alpha:0.
|
|
in
|
|
set_fill_paint vg ~paint:img_paint;
|
|
fill vg;
|
|
P2.v (P2.x b +. w) (P2.y b +. h)
|
|
| `Uchar uc -> uchar vg b uc
|
|
| `Boundary _ -> b
|
|
| `Hint _ -> b
|
|
| `Empty -> b
|
|
|
|
and attr t b ((a : attr), n) : P2.t =
|
|
match a with
|
|
| `Style s ->
|
|
path_box t.vg s.bg
|
|
(Box2.of_pts b
|
|
(node { t with style = Style.merge t.style s } b n))
|
|
| `Pad p -> pad t b p n
|
|
| `Draw d -> d t b
|
|
| `Handler _ -> node t b n
|
|
|
|
and pad vg t (p : Pad.t) n =
|
|
let nv = node vg P2.(v (p.l +. x t) (p.t +. y t)) n in
|
|
P2.(v (x nv +. p.r) (y nv +. p.b))
|
|
|
|
and join vg t (d, a, b) : P2.t =
|
|
let av = node vg t a in
|
|
let bv =
|
|
node vg
|
|
(match d with
|
|
| `X -> P2.v (P2.x av) (P2.y t)
|
|
| `Y -> P2.v (P2.x t) (P2.y av)
|
|
| `Z -> t)
|
|
b
|
|
in
|
|
match d with
|
|
| `X -> V2.v (V2.x bv) (Float.max_num (V2.y av) (V2.y bv))
|
|
| `Y -> V2.v (Float.max_num (V2.x av) (V2.x bv)) (V2.y bv)
|
|
| `Z ->
|
|
V2.v
|
|
(Float.max_num (V2.x av) (V2.x bv))
|
|
(Float.max_num (V2.y av) (V2.y bv))
|
|
|
|
and node t b (n : node) : P2.t =
|
|
let b' =
|
|
match n.t with
|
|
| `Atom a -> atom t b a
|
|
| `Attr a -> attr t b a
|
|
| `Join a -> join t b a
|
|
in
|
|
(*ignore
|
|
(Display.path_box t.vg
|
|
(Color.rgbaf ~r:1. ~g:0. ~b:0. ~a:0.2)
|
|
(Box2.of_pts b b') ) ; *)
|
|
b'
|
|
end
|
|
|
|
module Action = struct
|
|
type segment =
|
|
[ `Beginning of boundary
|
|
| `Forward of boundary
|
|
| `Backward of boundary
|
|
| `End of boundary ]
|
|
|
|
and t =
|
|
[ `Move of segment
|
|
| `Insert of node
|
|
| `Overwrite of node
|
|
| `Yank of segment
|
|
| `Kill of segment
|
|
| `Ascend
|
|
| `Descend
|
|
| `Custom of string * (node -> t Key.Bind.t -> unit Lwt.t) ]
|
|
|
|
and dir =
|
|
[ `Next
|
|
| `Prev
|
|
| `Up
|
|
| `Down
|
|
| `Left
|
|
| `Right
|
|
| `Fwd
|
|
| `Enter
|
|
| `In
|
|
| `Out ]
|
|
|
|
open Fmt
|
|
|
|
let pp_dir ppf v =
|
|
any
|
|
(match v with
|
|
| `Next -> "`Next"
|
|
| `Prev -> "`Prev"
|
|
| `Up -> "`Up"
|
|
| `Down -> "`Down"
|
|
| `Left -> "`Left"
|
|
| `Right -> "`Right"
|
|
| `Fwd -> "`Fwd"
|
|
| `Enter -> "`Enter"
|
|
| `In -> "`In"
|
|
| `Out -> "`Out")
|
|
ppf ()
|
|
|
|
let pp_segment ppf v =
|
|
(match v with
|
|
| `Beginning s -> any "`Beginning " ++ const pp_boundary s
|
|
| `Forward s -> any "`Forward " ++ const pp_boundary s
|
|
| `Backward s -> any "`Backward " ++ const pp_boundary s
|
|
| `End s -> any "`End " ++ const pp_boundary s)
|
|
ppf ()
|
|
|
|
let pp_t ppf v =
|
|
(match v with
|
|
| `Move s -> any "`Move " ++ const pp_segment s
|
|
| `Insert n -> any "`Insert " ++ const pp_node n
|
|
| `Overwrite n -> any "`Overwrite " ++ const pp_node n
|
|
| `Yank s -> any "`Yank " ++ const pp_segment s
|
|
| `Kill s -> any "`Kill " ++ const pp_segment s
|
|
| `Ascend -> any "`Ascend"
|
|
| `Descend -> any "`Descend"
|
|
| `Custom (s, _) ->
|
|
fun ppf () -> pf ppf "`Custom \"%a\"" string s)
|
|
ppf ()
|
|
end
|
|
|
|
let perform_action (a : Action.t) (c : cursor) : node option =
|
|
match a with
|
|
| `Move (`Forward `Line) -> (
|
|
let i = ref 0 in
|
|
ignore
|
|
(search_backward
|
|
(function
|
|
| { t = `Atom (`Boundary `Line); _ } -> Some ()
|
|
| { t = `Atom (`Uchar _); _ } ->
|
|
incr i;
|
|
None
|
|
| _ -> None)
|
|
c.sel);
|
|
match search_forward (is_boundary `Line) c.sel with
|
|
| Some n' ->
|
|
Some
|
|
(tree_iter
|
|
(fun nn ->
|
|
Option.value
|
|
(search_forward (is_boundary `Char) nn)
|
|
~default:nn)
|
|
n' !i)
|
|
| None -> None)
|
|
| `Move (`Backward `Line) -> (
|
|
let i = ref 0 in
|
|
match
|
|
search_backward
|
|
(function
|
|
| { t = `Atom (`Boundary `Line); _ } as n' -> Some n'
|
|
| { t = `Atom (`Uchar _); _ } ->
|
|
incr i;
|
|
None
|
|
| _ -> None)
|
|
c.sel
|
|
with
|
|
| Some n' ->
|
|
Option.map
|
|
(fun n -> tree_iter tree_uchar_back n !i)
|
|
(search_backward (is_boundary `Line) n')
|
|
| None -> None)
|
|
| `Move (`Forward b) ->
|
|
Option.map tree_uchar_fwd
|
|
(search_forward (is_boundary b) c.sel)
|
|
| `Move (`End b) ->
|
|
Option.map tree_uchar_back
|
|
(search_forward (is_boundary b) c.sel)
|
|
| `Move (`Backward b) ->
|
|
Option.map tree_uchar_back
|
|
(search_backward (is_boundary b) c.sel)
|
|
| `Move (`Beginning b) ->
|
|
Option.map tree_uchar_fwd
|
|
(search_backward (is_boundary b) c.sel)
|
|
| `Insert n ->
|
|
ignore (insert_join_l `X (super c.sel) n);
|
|
Some c.sel
|
|
| `Overwrite _s -> None
|
|
| `Yank _s -> None
|
|
| `Kill (`Forward `Char) -> None (*kill_forward_char c.sel *)
|
|
| `Kill (`Backward `Char) -> kill_backward_char c.sel
|
|
| `Kill _s -> None
|
|
| `Descend -> Some (sub c.sel)
|
|
| `Ascend -> option_of_parent c.sel.parent
|
|
| `Custom _s -> None
|
|
|
|
type event_status = [ `Handled | `Event of Event.t ]
|
|
|
|
let textedit_bindings =
|
|
let open Key.Bind in
|
|
empty
|
|
|> add [ ([ Ctrl ], C 'f') ] [ `Move (`Forward `Char) ]
|
|
|> add [ ([], U (`Arrow `Right)) ] [ `Move (`Forward `Char) ]
|
|
|> add [ ([ Ctrl ], C 'b') ] [ `Move (`Backward `Char) ]
|
|
|> add [ ([], U (`Arrow `Left)) ] [ `Move (`Backward `Char) ]
|
|
|> add [ ([ Meta ], C 'f') ] [ `Move (`Forward `Word) ]
|
|
|> add [ ([ Meta ], C 'b') ] [ `Move (`Backward `Word) ]
|
|
|> add
|
|
[ ([ Ctrl ], C 'c'); ([ Ctrl ], C 'n') ]
|
|
[ `Move (`Forward `Phrase) ]
|
|
|> add
|
|
[ ([ Ctrl ], C 'c'); ([ Ctrl ], C 'p') ]
|
|
[ `Move (`Backward `Phrase) ]
|
|
|> add [ ([ Ctrl ], C 'n') ] [ `Move (`Forward `Line) ]
|
|
|> add [ ([], U (`Arrow `Down)) ] [ `Move (`Forward `Line) ]
|
|
|> add [ ([ Ctrl ], C 'p') ] [ `Move (`Backward `Line) ]
|
|
|> add [ ([], U (`Arrow `Up)) ] [ `Move (`Backward `Line) ]
|
|
|> add [ ([ Ctrl ], C 'v') ] [ `Move (`Forward `Page) ]
|
|
|> add [ ([ Meta ], C 'v') ] [ `Move (`Backward `Page) ]
|
|
|> add [ ([ Ctrl ], C 'a') ] [ `Move (`Beginning `Line) ]
|
|
|> add [ ([ Ctrl ], C 'e') ] [ `Move (`End `Line) ]
|
|
|> add [ ([ Ctrl ], C 'k') ] [ `Kill (`End `Line) ]
|
|
|> add [ ([], U `Backspace) ] [ `Kill (`Backward `Char) ]
|
|
|> add [ ([], U `Delete) ] [ `Kill (`Forward `Char) ]
|
|
|> add [ ([ Ctrl ], U `Backspace) ] [ `Kill (`Backward `Word) ]
|
|
|> add [ ([ Meta ], U `Backspace) ] [ `Kill (`Backward `Word) ]
|
|
|> add
|
|
[ ([ Ctrl ], C 'x'); ([], U `Backspace) ]
|
|
[ `Kill (`Backward `Phrase) ]
|
|
|> add [ ([ Ctrl ], C 'q') ] [ `Ascend ]
|
|
|> add [ ([ Ctrl ], C 'z') ] [ `Descend ]
|
|
|
|
let cursor_attr =
|
|
`Style Style.(bg NVG.Color.(rgbaf ~r:1. ~g:1. ~b:0. ~a:1.))
|
|
|
|
let draw_cursor_root (c : cursor) : node =
|
|
let open Gg in
|
|
attr
|
|
(`Draw
|
|
(fun (t : draw_context) (b : P2.t) ->
|
|
Draw.node t b
|
|
(Text.lines (Fmt.to_to_string pp_node_structure c.root))))
|
|
(atom `Empty)
|
|
|
|
let draw_cursor_sel (c : cursor) : node =
|
|
let open Gg in
|
|
attr
|
|
(`Draw
|
|
(fun (t : draw_context) (b : P2.t) ->
|
|
Draw.node t b
|
|
(Text.lines (Fmt.to_to_string pp_node (sub c.sel)))))
|
|
(atom `Empty)
|
|
|
|
let textedit ?(bindings = textedit_bindings) (n : node) =
|
|
Format.pp_set_max_boxes F.stderr 64;
|
|
(*full screen fynn *)
|
|
Format.pp_safe_set_geometry F.stderr ~max_indent:150 ~margin:230;
|
|
let bind = Key.Bind.init bindings in
|
|
let sel = insert_attr cursor_attr n in
|
|
let c = { root = attr (`Handler (fun _ _ -> None)) sel; sel } in
|
|
c.root.t <-
|
|
`Attr
|
|
( `Handler
|
|
(fun (_ : node) (e : Event.t) : Event.t option ->
|
|
let a =
|
|
match Key.Bind.resolve_events bind [ e ] with
|
|
| x :: _ -> Some x
|
|
| [] -> (
|
|
match e with
|
|
| `Key (`Press, (k : Key.keystate)) -> (
|
|
match k.code with
|
|
| `Uchar c ->
|
|
Some (`Insert (atom (`Uchar c)))
|
|
| _ -> None)
|
|
| _ -> None)
|
|
in
|
|
let r =
|
|
match a with
|
|
| Some x ->
|
|
c.sel <- remove_attr c.sel;
|
|
(match perform_action x c with
|
|
| Some n' ->
|
|
F.epr "textedit action @[%a@] Success@."
|
|
Action.pp_t x;
|
|
c.sel <- n'
|
|
| None ->
|
|
F.epr "textedit action @[%a@] Failure@."
|
|
Action.pp_t x);
|
|
c.sel <- insert_attr cursor_attr c.sel;
|
|
None
|
|
| None -> None
|
|
in
|
|
r),
|
|
n );
|
|
join_y (pad 5. c.root)
|
|
(join_y
|
|
(pad 5. (draw_cursor_sel c))
|
|
(pad 5. (draw_cursor_root c)))
|
|
|
|
let handler_of_node (n : node) : handler option =
|
|
let f n =
|
|
match n.t with `Attr (`Handler f, _) -> Some f | _ -> None
|
|
in
|
|
match f n with Some a -> Some a | None -> search_forward f n
|
|
|
|
let handle_event (n : node) (ev : Event.t) : event_status =
|
|
match handler_of_node n with
|
|
| Some f -> (
|
|
match f n ev with Some ev -> `Event ev | None -> `Handled)
|
|
| None -> `Event ev
|
|
|
|
let panel (vg : NVG.t) (p : P2.t) (t : node) (ev : Event.t) : P2.t
|
|
=
|
|
(match handle_event t ev with
|
|
| `Handled -> F.epr "Handled %s@." (Event.to_string ev)
|
|
| `Event _e ->
|
|
F.epr "Unhandled event: %s@." (Event.to_string _e));
|
|
Draw.node { vg; style = Style.dark } p t
|
|
|
|
(* I feel like the Wall module from github.com/let-def/wall includes another layer on top
|
|
of the drawing functions, missing from graphv, that
|
|
specificall allows the composability and cache-ability i want, so instead of writing in from
|
|
scratch i will try to steal it.
|
|
*)
|
|
|
|
module View = struct
|
|
open Lwt.Infix
|
|
|
|
let tree = ref (Nav.test_pull ())
|
|
let cursor = ref []
|
|
|
|
let contents tree =
|
|
Nav.S.Tree.list tree !cursor >>= fun l ->
|
|
Lwt.return
|
|
(String.concat "\n" (List.map (fun (step, _t') -> step) l))
|
|
|
|
type t = { tree : Nav.tree; mutable cursor : Nav.step }
|
|
|
|
let draw (vg, p) tree : p Lwt.t =
|
|
contents tree >>= fun contents ->
|
|
Lwt.return (Draw.node vg p (textedit (Text.lines contents)))
|
|
end
|
|
|
|
open Lwt.Infix
|
|
|
|
let render_lwt (vg : NVG.t) (p : p) (_ev : Event.t) : p Lwt.t =
|
|
let t = { vg; style = Style.dark } in
|
|
!View.tree >>= fun tree ->
|
|
View.draw (t, p) tree >>= fun p ->
|
|
let module Buffer = Stdlib.Buffer in
|
|
Lwt.return
|
|
(Draw.node t p
|
|
(Text.lines (Buffer.contents Logs_reporter.log_buf)))
|
|
end
|
|
end
|
|
|
|
(* Implement the "window management" as just toplevel defined functions that manipulate the window tree *)
|
|
|
|
(* FUTURE: (thinking now this should be based on react for that sweet incremental compuation)
|
|
|
|
type panetree
|
|
type eventree
|
|
type imagetree
|
|
|
|
Display.run should be:
|
|
Init: setup initial panetree and compute eventree and imagetree from it.last_actions
|
|
New events trigger parsing the eventree, the results of which update the imagetree
|
|
which is then parsed and displayed. *)
|
|
|
|
(* 220805: This is fundamentally trying to:
|
|
- display lines of text in a variety of ways
|
|
- allow manipulation of the display of the document
|
|
- display and manipulate history of the document
|
|
- turn the document into a tree
|
|
the
|
|
|
|
your previous idea around the binary tree display layout is ok but is it really trying to shove documents into trees when you can't then de-encode them into a file? That seems rough...
|
|
|
|
you have an in-memory irmin store, and you really just want to be able to navigate it
|
|
but it's going to be lots of linear things (the internet, lol), so you still need linear document navigation
|
|
but what if you can rethink linear document navigation but switching the tree structure around while still making the layout a tree (Irmin.Tree), but now the history is a tree (Irmin.History) which just encodes the state of the display. This would require an in-memory Irmin store that
|
|
|
|
If the Irmin Tree is better implemented than the garbage i am trying to make ad hoc, (i.e. we can implement all our cursor movement and editing mechanisms with the Irmin.Tree interface easily, then yea lol)
|
|
*)
|
|
|
|
(* would be nice to be able to switch arbitrary nodes between their drawn representation and the sort of node structure representation. This might be a more general philsophy to apply to the entire system, where you want to be able to switch between representations (i.e. "view-source" but with further higher level analysis views built on top as well *)
|