new key handling and keybinding
This commit is contained in:
cqc
482
main.ml
482
main.ml
@ -2,31 +2,166 @@ open Lwt.Infix
|
||||
module F = Fmt
|
||||
module Store = Irmin_unix.Git.FS.KV (Irmin.Contents.String)
|
||||
|
||||
module Display = struct
|
||||
open Tgles2
|
||||
open Tsdl
|
||||
open Gg
|
||||
|
||||
module Input = struct
|
||||
|
||||
open CamomileLibrary
|
||||
open Zed_edit
|
||||
|
||||
|
||||
open CamomileLibrary
|
||||
|
||||
let ( >>= ) x f = match x with Ok a -> f a | Error _ as result -> result
|
||||
(** Type of key code. *)
|
||||
type code =
|
||||
| Char of UChar.t (** A unicode character. *)
|
||||
| Enter
|
||||
| Escape
|
||||
| Tab
|
||||
| Up
|
||||
| Down
|
||||
| Left
|
||||
| Right
|
||||
| F1
|
||||
| F2
|
||||
| F3
|
||||
| F4
|
||||
| F5
|
||||
| F6
|
||||
| F7
|
||||
| F8
|
||||
| F9
|
||||
| F10
|
||||
| F11
|
||||
| F12
|
||||
| Next_page
|
||||
| Prev_page
|
||||
| Home
|
||||
| End
|
||||
| Insert
|
||||
| Delete
|
||||
| Backspace
|
||||
| Unknown
|
||||
| None
|
||||
|
||||
let get_result = function Ok x -> x | Error (`Msg msg) -> failwith msg
|
||||
module KeymodSet = struct
|
||||
type t = Shift | Ctrl | Meta | Fn
|
||||
let compare (x : t) (y : t) = compare x y
|
||||
end
|
||||
|
||||
module Keymod = Set.Make(KeymodSet)
|
||||
|
||||
type key = { mods : Keymod.t; code : code ; }
|
||||
module Key = struct
|
||||
type t = key
|
||||
let compare (x : t) (y : t) = compare x y
|
||||
end
|
||||
|
||||
type keymod = Shift | Ctrl | Meta | Fn
|
||||
module Bind = struct
|
||||
module S = Zed_input.Make(Key)
|
||||
include S
|
||||
type action = Custom of (unit -> unit) | Zed of Zed_edit.action
|
||||
(* stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *)
|
||||
let bindings = ref empty
|
||||
|
||||
let bind seq actions = bindings := add seq actions !bindings
|
||||
let unbind seq = bindings := remove seq !bindings
|
||||
|
||||
type key = {
|
||||
char : char;
|
||||
uchar : CamomileLibrary.UChar.t;
|
||||
keycode : Sdl.keycode;
|
||||
scancode : Sdl.scancode;
|
||||
mods : keymod list;
|
||||
}
|
||||
type t = action list S.t
|
||||
type resolver = action list S.resolver
|
||||
type result = action list S.result
|
||||
let default_resolver b = resolver [ pack (fun (x: action list) -> x) b ]
|
||||
|
||||
let get_resolver result default = match result with | Continue r -> r | _ -> default
|
||||
|
||||
let handle_actions actions zectx =
|
||||
List.iter (function
|
||||
| Custom f -> f ()
|
||||
| Zed za -> Zed_edit.get_action za zectx)
|
||||
actions
|
||||
end
|
||||
|
||||
(* stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *)
|
||||
let string_of_code = function
|
||||
| Char ch -> Printf.sprintf "Char 0x%02x" (UChar.code ch)
|
||||
| Enter -> "Enter"
|
||||
| Escape -> "Escape"
|
||||
| Tab -> "Tab"
|
||||
| Up -> "Up"
|
||||
| Down -> "Down"
|
||||
| Left -> "Left"
|
||||
| Right -> "Right"
|
||||
| F1 -> "F1"
|
||||
| F2 -> "F2"
|
||||
| F3 -> "F3"
|
||||
| F4 -> "F4"
|
||||
| F5 -> "F5"
|
||||
| F6 -> "F6"
|
||||
| F7 -> "F7"
|
||||
| F8 -> "F8"
|
||||
| F9 -> "F9"
|
||||
| F10 -> "F10"
|
||||
| F11 -> "F11"
|
||||
| F12 -> "F12"
|
||||
| Next_page -> "Next_page"
|
||||
| Prev_page -> "Prev_page"
|
||||
| Home -> "Home"
|
||||
| End -> "End"
|
||||
| Insert -> "Insert"
|
||||
| Delete -> "Delete"
|
||||
| Backspace -> "Backspace"
|
||||
| Unknown -> "Unknown"
|
||||
| None -> "None"
|
||||
|
||||
let to_string key =
|
||||
Printf.sprintf "{ control = %B; meta = %B; shift = %B; fn = %B; code = %s }"
|
||||
(Keymod.mem Ctrl key.mods)
|
||||
(Keymod.mem Meta key.mods)
|
||||
(Keymod.mem Shift key.mods)
|
||||
(Keymod.mem Fn key.mods)
|
||||
(string_of_code key.code)
|
||||
|
||||
let to_string_compact key =
|
||||
let buffer = Buffer.create 32 in
|
||||
if (Keymod.mem Ctrl key.mods) then Buffer.add_string buffer "C-";
|
||||
if (Keymod.mem Meta key.mods) then Buffer.add_string buffer "M-";
|
||||
if (Keymod.mem Shift key.mods) then Buffer.add_string buffer "S-";
|
||||
if (Keymod.mem Fn key.mods) then Buffer.add_string buffer "Fn-";
|
||||
(match key.code with
|
||||
| Char ch ->
|
||||
let code = UChar.code ch in
|
||||
if code <= 255 then
|
||||
match Char.chr code 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
|
||||
| Next_page -> Buffer.add_string buffer "next"
|
||||
| Prev_page -> Buffer.add_string buffer "prev"
|
||||
| code -> Buffer.add_string buffer (String.lowercase_ascii (string_of_code code))
|
||||
);
|
||||
Buffer.contents buffer
|
||||
end
|
||||
|
||||
module Event = struct
|
||||
open Tsdl
|
||||
open CamomileLibrary
|
||||
open Zed_edit
|
||||
open Input
|
||||
open Input.KeymodSet
|
||||
|
||||
type mouse = int * int
|
||||
|
||||
|
||||
type event =
|
||||
[ `Key_down of key
|
||||
| `Key_up of key
|
||||
[ `Key_down of Input.key
|
||||
| `Key_up of Input.key
|
||||
| `Text_editing of string
|
||||
| `Text_input of string
|
||||
| `Mouse of mouse
|
||||
@ -34,52 +169,46 @@ module Display = struct
|
||||
| `Fullscreen of bool
|
||||
| `None ]
|
||||
|
||||
let str_of_key k =
|
||||
Printf.sprintf
|
||||
"(char=%C;uchar=%C;keycode=%x;scancode=%x;name=%s;(%s%s%s%s))" k.char
|
||||
(CamomileLibrary.UChar.char_of k.uchar)
|
||||
k.keycode k.scancode
|
||||
(Sdl.get_key_name k.keycode)
|
||||
(if List.mem Shift k.mods then "shift" else "")
|
||||
(if List.mem Ctrl k.mods then "ctrl" else "")
|
||||
(if List.mem Meta k.mods then "meta" else "")
|
||||
(if List.mem Fn k.mods then " fn" else "")
|
||||
|
||||
let event_of_sdlevent ev =
|
||||
let key_of_sdlkey ev =
|
||||
let km = Sdl.Event.get ev Sdl.Event.keyboard_keymod in
|
||||
let (kc : Sdl.keycode) = (Sdl.Event.get ev Sdl.Event.keyboard_keycode) land (lnot Sdl.K.scancode_mask) in
|
||||
let open Sdl.K in
|
||||
let (c : Input.code) =
|
||||
match (kc : Sdl.keycode) with
|
||||
(* HACK WHENENENENENENENENEHWEHWEHNWEWHWEHWEN FUCK X WHEN X whatS>!!>!> *)
|
||||
| x when x = return -> Enter | x when x = escape -> Escape
|
||||
| x when x = backspace -> Backspace | x when x = tab -> Tab
|
||||
| x when x = f1 -> F1 | x when x = f2 -> F2
|
||||
| x when x = f3 -> F3 | x when x = f4 -> F4
|
||||
| x when x = f5 -> F5 | x when x = f6 -> F6
|
||||
| x when x = f7 -> F7 | x when x = f8 -> F8
|
||||
| x when x = f9 -> F9 | x when x = f10 -> F10
|
||||
| x when x = f11 -> F11 | x when x = f12 -> F12
|
||||
| x when x = insert -> Insert | x when x = delete -> Delete
|
||||
| x when x = home -> Home | x when x = kend -> End
|
||||
| x when x = pageup -> Prev_page | x when x = pagedown -> Next_page
|
||||
| x when x = right -> Right | x when x = left -> Left
|
||||
| x when x = down -> Down | x when x = up -> Up
|
||||
| k -> (match UChar.char_of (UChar.of_int k) with
|
||||
| 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9'
|
||||
| '_' | '(' | ')' | '[' | ']' | '{' | '}'
|
||||
| '#' | '~' | '&' | '$' | '*' | '%'
|
||||
| '!' | '?' | ',' | ';' | ':' | '/' | '\\'
|
||||
| '.' | '@' | '=' | '+' | '-' | ' '
|
||||
| '"' | '\'' | '>' | '<' | '^' | '`' | '|' -> Char (UChar.of_int k)
|
||||
| _ -> None) in
|
||||
let mods = List.filter_map (fun (m, v) -> if km land m > 0 then Some v else None)
|
||||
Sdl.Kmod.[ (shift, Shift); (ctrl, Ctrl); (alt, Meta); (gui, Fn) ] in
|
||||
{ code = c; mods = Input.Keymod.of_list mods; } in
|
||||
let repeat = Sdl.Event.get ev Sdl.Event.keyboard_repeat in
|
||||
match Sdl.Event.enum (Sdl.Event.get ev Sdl.Event.typ) with
|
||||
| `Text_editing ->
|
||||
`None
|
||||
| `Text_editing -> `None
|
||||
| `Text_input -> `Text_input (Sdl.Event.get ev Sdl.Event.text_input_text)
|
||||
| (`Key_down | `Key_up) as w ->
|
||||
let km = Sdl.Event.get ev Sdl.Event.keyboard_keymod in
|
||||
let keycode = Sdl.Event.get ev Sdl.Event.keyboard_keycode in
|
||||
let uchar =
|
||||
CamomileLibrary.UChar.of_int
|
||||
(if keycode land Sdl.K.scancode_mask > 0 then 0 else keycode)
|
||||
in
|
||||
let mods =
|
||||
List.filter_map
|
||||
(fun (m, v) -> if km land m > 0 then Some v else None)
|
||||
Sdl.Kmod.[ (shift, Shift); (ctrl, Ctrl); (alt, Meta); (gui, Fn) ]
|
||||
in
|
||||
let k =
|
||||
{
|
||||
char = UChar.char_of uchar;
|
||||
uchar;
|
||||
keycode;
|
||||
scancode = Sdl.Event.get ev Sdl.Event.keyboard_scancode;
|
||||
mods;
|
||||
}
|
||||
in
|
||||
let repeat = Sdl.Event.get ev Sdl.Event.keyboard_repeat in
|
||||
if repeat < 1 then
|
||||
match w with `Key_down -> `Key_down k | `Key_up -> `Key_up k
|
||||
else `None
|
||||
| `Mouse_motion ->
|
||||
let _, mouse_xy = Tsdl.Sdl.get_mouse_state () in
|
||||
`Mouse mouse_xy
|
||||
| `Quit ->
|
||||
`Quit
|
||||
| `Key_down -> if repeat < 1 then `Key_down (key_of_sdlkey ev) else `None
|
||||
| `Key_up -> if repeat < 1 then `Key_up (key_of_sdlkey ev) else `None
|
||||
| `Mouse_motion -> let _, mouse_xy = Tsdl.Sdl.get_mouse_state () in `Mouse mouse_xy
|
||||
| `Quit -> `Quit
|
||||
| _ -> (*F.epr "Unknown Event@." ; *) `None
|
||||
|
||||
let key_up : Sdl.keycode = 0x40000052
|
||||
@ -92,12 +221,25 @@ module Display = struct
|
||||
|
||||
let handle_keyevents (el : event list) f = List.iter f el
|
||||
|
||||
end
|
||||
|
||||
module Display = struct
|
||||
open Tgles2
|
||||
open Tsdl
|
||||
open Gg
|
||||
open CamomileLibrary
|
||||
open Zed_edit
|
||||
|
||||
let ( >>= ) x f = match x with Ok a -> f a | Error _ as result -> result
|
||||
|
||||
let get_result = function Ok x -> x | Error (`Msg msg) -> failwith msg
|
||||
|
||||
(* current window state to be passed to window renderer *)
|
||||
type state = {
|
||||
box : box2;
|
||||
(* This is cannonically box within which the next element should draw *)
|
||||
time : float;
|
||||
events : event list;
|
||||
events : Event.event list;
|
||||
wall : Wall.renderer;
|
||||
}
|
||||
|
||||
@ -146,7 +288,7 @@ module Display = struct
|
||||
let ev = Sdl.Event.create () in
|
||||
let el = ref [ `None ] in
|
||||
while Sdl.wait_event_timeout (Some ev) 50 (* HACK *) do
|
||||
let e = event_of_sdlevent ev in
|
||||
let e = Event.event_of_sdlevent ev in
|
||||
if e != `None then el := !el @ [ e ]
|
||||
(* HACK? *)
|
||||
done;
|
||||
@ -234,7 +376,7 @@ let load_font name =
|
||||
| Some font -> font
|
||||
|
||||
let font_icons = lazy (load_font "fonts/entypo.ttf")
|
||||
|
||||
|
||||
let font_sans = lazy (load_font "fonts/Roboto-Regular.ttf")
|
||||
|
||||
let font_sans_bold = lazy (load_font "fonts/Roboto-Bold.ttf")
|
||||
@ -431,67 +573,126 @@ let draw_pp height fpp (s : Display.state) =
|
||||
Format.pp_force_newline pp ();
|
||||
(!sc, (Box2.of_pts (Box2.o s.box) (P2.v !max_x (Box2.maxy !box)), !node))
|
||||
|
||||
type textedit = { ze : unit Zed_edit.t; zc : Zed_cursor.t }
|
||||
|
||||
let default_bindings =
|
||||
let open Input.Bind in
|
||||
let open CamomileLibrary in
|
||||
let open Zed_edit in
|
||||
let m = Input.Keymod.of_list in
|
||||
let b = ref empty in
|
||||
let add e a = b := Input.Bind.add e a !b in
|
||||
add [{ mods = m []; code = Left }] [Zed Prev_char];
|
||||
add [{ mods = m []; code = Right }] [Zed Next_char];
|
||||
add [{ mods = m []; code = Up }] [Zed Prev_line];
|
||||
add [{ mods = m []; code = Down }] [Zed Next_line];
|
||||
add [{ mods = m []; code = Home }] [Zed Goto_bol];
|
||||
add [{ mods = m []; code = End }] [Zed Goto_eol];
|
||||
add [{ mods = m []; code = Insert }] [Zed Switch_erase_mode];
|
||||
add [{ mods = m []; code = Delete }] [Zed Delete_next_char];
|
||||
add [{ mods = m []; code = Enter }] [Zed Newline];
|
||||
add [{ mods = m [Ctrl]; code = Char(UChar.of_char ' ') }] [Zed Set_mark];
|
||||
add [{ mods = m [Ctrl]; code = Char(UChar.of_char 'a') }] [Zed Goto_bol];
|
||||
add [{ mods = m [Ctrl]; code = Char(UChar.of_char 'e') }] [Zed Goto_eol];
|
||||
add [{ mods = m [Ctrl]; code = Char(UChar.of_char 'd') }] [Zed Delete_next_char];
|
||||
add [{ mods = m [Ctrl]; code = Char(UChar.of_char 'h') }] [Zed Delete_prev_char];
|
||||
add [{ mods = m [Ctrl]; code = Char(UChar.of_char 'k') }] [Zed Kill_next_line];
|
||||
add [{ mods = m [Ctrl]; code = Char(UChar.of_char 'u') }] [Zed Kill_prev_line];
|
||||
add [{ mods = m [Ctrl]; code = Char(UChar.of_char 'n') }] [Zed Next_line];
|
||||
add [{ mods = m [Ctrl]; code = Char(UChar.of_char 'p') }] [Zed Prev_line];
|
||||
add [{ mods = m [Ctrl]; code = Char(UChar.of_char 'w') }] [Zed Kill];
|
||||
add [{ mods = m [Ctrl]; code = Char(UChar.of_char 'y') }] [Zed Yank];
|
||||
add [{ mods = m []; code = Backspace }] [Zed Delete_prev_char];
|
||||
add [{ mods = m [Meta]; code = Char(UChar.of_char 'w') }] [Zed Copy];
|
||||
add [{ mods = m [Meta]; code = Char(UChar.of_char 'c') }] [Zed Capitalize_word];
|
||||
add [{ mods = m [Meta]; code = Char(UChar.of_char 'l') }] [Zed Lowercase_word];
|
||||
add [{ mods = m [Meta]; code = Char(UChar.of_char 'u') }] [Zed Uppercase_word];
|
||||
add [{ mods = m [Meta]; code = Char(UChar.of_char 'b') }] [Zed Prev_word];
|
||||
add [{ mods = m [Meta]; code = Char(UChar.of_char 'f') }] [Zed Next_word];
|
||||
add [{ mods = m [Meta]; code = Right }] [Zed Next_word];
|
||||
add [{ mods = m [Meta]; code = Left }] [Zed Prev_word];
|
||||
add [{ mods = m [Ctrl]; code = Right }] [Zed Next_word];
|
||||
add [{ mods = m [Ctrl]; code = Left }] [Zed Prev_word];
|
||||
add [{ mods = m [Meta]; code = Backspace }] [Zed Kill_prev_word];
|
||||
add [{ mods = m [Meta]; code = Delete }] [Zed Kill_prev_word];
|
||||
add [{ mods = m [Ctrl]; code = Delete }] [Zed Kill_next_word];
|
||||
add [{ mods = m [Meta]; code = Char(UChar.of_char 'd') }] [Zed Kill_next_word];
|
||||
add [{ mods = m [Ctrl]; code = Char(UChar.of_char '_') }] [Zed Undo];
|
||||
!b
|
||||
|
||||
type textedit = { ze : unit Zed_edit.t;
|
||||
zc : Zed_cursor.t;
|
||||
mutable bindings : Input.Bind.t;
|
||||
mutable binding_state : Input.Bind.result;
|
||||
mutable last_keyseq : Input.key list;
|
||||
mutable last_actions : Input.Bind.action list; }
|
||||
|
||||
let make_textedit () =
|
||||
let z = Zed_edit.create () in
|
||||
{ ze = z; zc = Zed_edit.new_cursor z }
|
||||
{ ze = z;
|
||||
zc = Zed_edit.new_cursor z;
|
||||
bindings = default_bindings;
|
||||
binding_state = Input.Bind.S.Rejected;
|
||||
last_keyseq = [{ mods = Input.Keymod.empty; code = Input.None;}];
|
||||
last_actions = [];}
|
||||
|
||||
let draw_textedit (te : textedit) height (s : Display.state) =
|
||||
let ctx = Zed_edit.context te.ze te.zc in
|
||||
List.iter
|
||||
(function
|
||||
| `Key_down (k : Display.key) -> (
|
||||
match k with
|
||||
| { keycode = kc; mods = []; _ } when kc = Display.key_up ->
|
||||
Zed_edit.prev_line ctx
|
||||
| { keycode = kc; mods = []; _ } when kc = Display.key_down ->
|
||||
Zed_edit.next_line ctx
|
||||
| { keycode = kc; mods = []; _ } when kc = Display.key_left ->
|
||||
Zed_edit.prev_char ctx
|
||||
| { keycode = kc; mods = []; _ } when kc = Display.key_right ->
|
||||
Zed_edit.next_char ctx
|
||||
| { char = '\r'; mods = []; _ } -> Zed_edit.newline ctx
|
||||
| { char = 'b'; mods = [ Ctrl ]; _ } -> Zed_edit.prev_char ctx
|
||||
| { char = 'f'; mods = [ Ctrl ]; _ } -> Zed_edit.next_char ctx
|
||||
| { char = 'a'; mods = [ Ctrl ]; _ } -> Zed_edit.goto_bol ctx
|
||||
| { char = 'e'; mods = [ Ctrl ]; _ } -> Zed_edit.goto_eol ctx
|
||||
| { char = 'd'; mods = [ Ctrl ]; _ } -> Zed_edit.remove_next ctx 1
|
||||
| { char = 'd'; mods = [ Meta ]; _ } -> Zed_edit.kill_next_word ctx
|
||||
| { char = '\b'; mods = []; _ } -> Zed_edit.remove_prev ctx 1
|
||||
| { char = '\b'; mods = [ Meta ]; _ } -> Zed_edit.kill_prev_word ctx
|
||||
| { char = '\t'; mods = []; _ } ->
|
||||
Zed_edit.insert_char ctx (CamomileLibrary.UChar.of_char '\t')
|
||||
| { char = 'k'; mods = [ Ctrl ]; _ } -> Zed_edit.kill_next_line ctx
|
||||
| _ -> ())
|
||||
List.iter (function
|
||||
| `Key_down (k : Input.key) ->
|
||||
let open Input.Bind in
|
||||
(match te.binding_state with
|
||||
| Accepted _ | Rejected -> te.last_keyseq <- []; te.last_actions <- []
|
||||
| Continue _ -> ());
|
||||
te.binding_state <- resolve k (get_resolver te.binding_state (default_resolver te.bindings));
|
||||
te.last_keyseq <- k :: te.last_keyseq;
|
||||
(match te.binding_state with
|
||||
| Accepted a ->
|
||||
te.last_actions <- a;
|
||||
List.iter (function
|
||||
| Input.Bind.Custom f -> f ()
|
||||
| Zed za -> Zed_edit.get_action za ctx) a;
|
||||
| Continue _ -> ()
|
||||
| Rejected -> ())
|
||||
| `Key_up _ -> ()
|
||||
| `Text_input s ->
|
||||
Zed_edit.insert ctx (Zed_rope.of_string (Zed_string.of_utf8 s));
|
||||
()
|
||||
| _ -> ())
|
||||
s.events;
|
||||
let zs = (Zed_string.of_utf8 s) in
|
||||
F.epr "draw_textedit: `Text_input %s@." (Zed_string.to_utf8 zs);
|
||||
Zed_edit.insert ctx (Zed_rope.of_string zs)
|
||||
| _ -> ()) s.events;
|
||||
draw_pp height
|
||||
(fun pp ->
|
||||
let zrb, zra =
|
||||
Zed_rope.break (Zed_edit.text te.ze) (Zed_cursor.get_position te.zc)
|
||||
in
|
||||
let before_cursor = Zed_string.to_utf8 (Zed_rope.to_string zrb) in
|
||||
let after_cursor = Zed_string.to_utf8 (Zed_rope.to_string zra) in
|
||||
Format.pp_open_hvbox pp 0;
|
||||
F.text pp before_cursor;
|
||||
Format.pp_open_stag pp (Cursor (Wall.Color.v 0.99 0.99 0.125 0.3));
|
||||
F.pf pp "";
|
||||
Format.pp_close_stag pp ();
|
||||
F.text pp after_cursor;
|
||||
F.pf pp "@.";
|
||||
Format.pp_close_box pp ())
|
||||
let zrb, zra =
|
||||
Zed_rope.break (Zed_edit.text te.ze) (Zed_cursor.get_position te.zc)
|
||||
in
|
||||
let before_cursor = Zed_string.to_utf8 (Zed_rope.to_string zrb) in
|
||||
let after_cursor = Zed_string.to_utf8 (Zed_rope.to_string zra) in
|
||||
Format.pp_open_hvbox pp 0;
|
||||
F.text pp before_cursor;
|
||||
Format.pp_open_stag pp (Cursor (Wall.Color.v 0.99 0.99 0.125 0.3));
|
||||
F.pf pp "";
|
||||
Format.pp_close_stag pp ();
|
||||
F.text pp after_cursor;
|
||||
F.pf pp "@.";
|
||||
Format.pp_close_box pp ())
|
||||
s
|
||||
|
||||
let draw_textedit_input height (te : textedit) =
|
||||
draw_pp height (fun pp ->
|
||||
Format.pp_open_hbox pp ();
|
||||
F.text pp (List.fold_right (fun x s -> (Input.to_string_compact x) ^ " " ^ s) te.last_keyseq "");
|
||||
F.text pp (List.fold_right (fun x s ->
|
||||
s ^ "-> " ^
|
||||
Input.Bind.(match x with
|
||||
| Zed a -> Zed_edit.name_of_action a
|
||||
| Custom _ -> "Custom")) te.last_actions "");
|
||||
Format.pp_close_box pp ();
|
||||
F.flush pp ())
|
||||
|
||||
let str_of_textedit (te : textedit) =
|
||||
Zed_string.to_utf8 (Zed_rope.to_string (Zed_edit.text te.ze))
|
||||
|
||||
|
||||
type storeview = { s : Store.t; path : string list }
|
||||
|
||||
|
||||
let make_storeview storepath branch ?(path = []) () =
|
||||
{
|
||||
s =
|
||||
@ -526,15 +727,6 @@ let draw_storeview (r : storeview) height (s : Display.state) =
|
||||
in
|
||||
draw_pp height (draw_levels root) s
|
||||
|
||||
type top = {
|
||||
te : textedit;
|
||||
res : Format.symbolic_output_buffer;
|
||||
mutable eval : Topinf.evalenv option;
|
||||
path : string list;
|
||||
histpath : string list;
|
||||
storeview : storeview;
|
||||
}
|
||||
|
||||
let format_symbolic_output_buffer (ppf : Format.formatter) buf =
|
||||
List.iter
|
||||
Format.(
|
||||
@ -558,6 +750,15 @@ let out_funs_of_sob sob =
|
||||
out_spaces = (fun n -> add_symbolic_output_item sob (Output_spaces n));
|
||||
}
|
||||
|
||||
type top = {
|
||||
te : textedit;
|
||||
res : Format.symbolic_output_buffer;
|
||||
mutable eval : Topinf.evalenv option;
|
||||
mutable path : string list;
|
||||
mutable histpath : string list;
|
||||
storeview : storeview;
|
||||
}
|
||||
|
||||
let make_top storepath ?(branch = "current") () =
|
||||
let t =
|
||||
{
|
||||
@ -581,47 +782,39 @@ let draw_top (t : top) height (s : Display.state) =
|
||||
let ppf = Format.formatter_of_symbolic_output_buffer t.res in
|
||||
Topinf.ppf := ppf;
|
||||
let eval =
|
||||
match t.eval with
|
||||
match t.eval with (* HACK use Lazy.? *)
|
||||
| None ->
|
||||
let e = match !Topinf.eval with | Some e -> e | None -> Topinf.init ppf in
|
||||
t.eval <- Some e;
|
||||
(* e ppf "#use \"init.ml\";;"; *)
|
||||
e
|
||||
| Some e -> e
|
||||
in
|
||||
(* HACK use Lazy.? *)
|
||||
Display.handle_keyevents s.events (function
|
||||
| `Key_up { char = '\r'; mods = [ Ctrl ]; _ } ->
|
||||
(* HACK overwriting stdout formatter because fucking ocaml/toplevel/topdirs.ml hardcodes it *)
|
||||
Format.pp_set_formatter_out_functions Format.std_formatter (out_funs_of_sob t.res);
|
||||
|
||||
ignore (Lwt_main.run (Store.tree t.storeview.s >>= fun tree ->
|
||||
Store.Tree.add tree (t.histpath @ ["input"]) (str_of_textedit t.te) ));
|
||||
|
||||
ignore (Format.flush_symbolic_output_buffer t.res);
|
||||
eval ppf (str_of_textedit t.te ^ ";;"); (*HACK to prevent getting stuck in parser*)
|
||||
|
||||
let b = Buffer.create 69 in
|
||||
format_symbolic_output_buffer (Format.formatter_of_buffer b) (Format.get_symbolic_output_buffer t.res);
|
||||
ignore (Lwt_main.run (Store.tree t.storeview.s >>= fun tree ->
|
||||
Store.Tree.add tree (t.histpath @ ["output"]) (Buffer.contents b)));
|
||||
ignore (Lwt_main.run (Store.set_exn t.storeview.s ~info:(Irmin_unix.info "history")
|
||||
t.path (str_of_textedit t.te)));
|
||||
Zed_edit.clear_data t.te.ze;
|
||||
| _ -> ());
|
||||
| Some e -> e in
|
||||
let eval () =
|
||||
ignore (Lwt_main.run (Store.tree t.storeview.s >>= fun tree ->
|
||||
Store.Tree.add tree (t.histpath @ ["input"]) (str_of_textedit t.te) ));
|
||||
ignore (Format.flush_symbolic_output_buffer t.res);
|
||||
eval ppf (str_of_textedit t.te ^ ";;"); (*HACK to prevent getting stuck in parser*)
|
||||
let b = Buffer.create 69 in
|
||||
format_symbolic_output_buffer (Format.formatter_of_buffer b) (Format.get_symbolic_output_buffer t.res);
|
||||
ignore (Lwt_main.run (Store.tree t.storeview.s >>= fun tree ->
|
||||
Store.Tree.add tree (t.histpath @ ["output"]) (Buffer.contents b)));
|
||||
ignore (Lwt_main.run (Store.set_exn t.storeview.s ~info:(Irmin_unix.info "history")
|
||||
t.path (str_of_textedit t.te)));
|
||||
Zed_edit.clear_data t.te.ze in
|
||||
t.te.bindings <- Input.(Bind.add [{mods = Keymod.of_list [Ctrl]; code = Enter}] Bind.[Custom eval] t.te.bindings);
|
||||
pane_vbox
|
||||
[
|
||||
draw_textedit t.te height;
|
||||
draw_pp height (fun pp ->
|
||||
Format.pp_open_hovbox pp 0;
|
||||
format_symbolic_output_buffer pp
|
||||
(Format.get_symbolic_output_buffer t.res);
|
||||
format_symbolic_output_buffer pp (Format.get_symbolic_output_buffer t.res);
|
||||
Format.pp_close_box pp ();
|
||||
F.flush pp ());
|
||||
draw_storeview t.storeview height;
|
||||
draw_textedit_input height t.te;
|
||||
]
|
||||
s
|
||||
|
||||
|
||||
let top_1 = make_top "../rootstore" ()
|
||||
|
||||
let draw_komm_default (s : Display.state) =
|
||||
@ -642,3 +835,4 @@ let () = Display.(run (make_frame ~title:"hi" ~w:1440 ~h:900 ()) !draw_komm) ()
|
||||
(* Implement the "window management" as just toplevel defined functions that manipulate the window tree *)
|
||||
|
||||
|
||||
|
||||
|
||||
Reference in New Issue
Block a user