2155 lines
73 KiB
OCaml
2155 lines
73 KiB
OCaml
(*
|
|
|
|
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 Lwt.Infix
|
|
module F = Fmt
|
|
|
|
module Input = struct
|
|
open CamomileLibrary
|
|
|
|
(** Type of key code. *)
|
|
type code =
|
|
| UChar 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
|
|
|
|
type keystate =
|
|
{ctrl: bool; meta: bool; shift: bool; super: bool; code: code}
|
|
|
|
type mods = Ctrl | Meta | Super | Shift
|
|
type key = Char of char | Code of code
|
|
|
|
module Key = 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 (Key)
|
|
|
|
type action =
|
|
| Custom of (unit -> unit)
|
|
| CustomLwt of (unit -> unit Lwt.t)
|
|
| Zed of Zed_edit.action
|
|
|
|
type t = action list S.t
|
|
type resolver = action list S.resolver
|
|
type result = action list S.result
|
|
|
|
type state =
|
|
{ mutable bindings: t
|
|
; mutable state: result
|
|
; mutable last_keyseq: keystate list
|
|
; mutable last_actions: action list }
|
|
|
|
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
|
|
| Char c -> UChar (UChar.of_char c)
|
|
| Code 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
|
|
|
|
let actions_of_events (state : state) events =
|
|
List.flatten
|
|
(List.filter_map
|
|
(fun e ->
|
|
(*F.epr "action_of_events: %s@." (to_string e) ;*)
|
|
match e with
|
|
| `Key_down (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 =
|
|
Lwt_list.iter_s
|
|
(function
|
|
| Custom f -> Lwt.return (f ())
|
|
| CustomLwt f -> f ()
|
|
| Zed _ -> Lwt.return_unit )
|
|
(actions_of_events bindstate events)
|
|
end
|
|
|
|
(* stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *)
|
|
let string_of_code = function
|
|
| UChar 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; 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.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 Input
|
|
|
|
type mouse = int * int
|
|
|
|
type t =
|
|
[ `Key_down of Input.keystate
|
|
| `Key_up of Input.keystate
|
|
| `Text_editing of string
|
|
| `Text_input of string
|
|
| `Mouse of mouse
|
|
| `Quit
|
|
| `Fullscreen of bool
|
|
| `Unknown of string
|
|
| `None ]
|
|
|
|
type events = t list
|
|
|
|
let string_of_event = function
|
|
| `Key_down _ -> "`Key_down"
|
|
| `Key_up _ -> "`Key_up"
|
|
| `Text_editing _ -> "`Text_editing"
|
|
| `Text_input _ -> "`Text_input"
|
|
| `Mouse _ -> "`Mouse"
|
|
| `Quit -> "`Quit"
|
|
| `Fullscreen _ -> "`Fullscreen"
|
|
| `Unknown _ -> "`Unknown"
|
|
| `None -> "`None"
|
|
|
|
let to_string ev =
|
|
let p =
|
|
match ev with
|
|
| `Key_down k | `Key_up k -> Input.to_string k
|
|
| `Text_editing s | `Text_input s -> s
|
|
| `Mouse _ -> ""
|
|
| `Fullscreen b -> Format.sprintf "%b" b
|
|
| `Unknown s -> s
|
|
| `Quit | `None -> "" in
|
|
string_of_event ev ^ " " ^ p
|
|
|
|
let event_of_sdlevent ev =
|
|
let key_of_sdlkey ev =
|
|
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'
|
|
|'_' | '(' | ')' | '[' | ']' | '{' | '}' | '#' | '~'
|
|
|'&' | '$' | '*' | '%' | '!' | '?' | ',' | ';' | ':'
|
|
|'/' | '\\' | '.' | '@' | '=' | '+' | '-' | ' ' | '"'
|
|
|'\'' | '>' | '<' | '^' | '`' | '|' ->
|
|
UChar (UChar.of_int k)
|
|
| _ -> None ) in
|
|
let km = Sdl.Event.get ev Sdl.Event.keyboard_keymod in
|
|
{ code= c
|
|
; ctrl= km land Sdl.Kmod.ctrl > 0
|
|
; meta= km land Sdl.Kmod.alt > 0
|
|
; super= km land Sdl.Kmod.gui > 0
|
|
; shift= km land Sdl.Kmod.shift > 0 } in
|
|
let repeat = Sdl.Event.get ev Sdl.Event.keyboard_repeat in
|
|
let r =
|
|
match Sdl.Event.enum (Sdl.Event.get ev Sdl.Event.typ) with
|
|
| `Text_editing ->
|
|
`Unknown
|
|
(Format.sprintf "`Text_editing %s"
|
|
(Sdl.Event.get ev Sdl.Event.text_editing_text) )
|
|
| `Text_input ->
|
|
`Text_input (Sdl.Event.get ev Sdl.Event.text_input_text)
|
|
| `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
|
|
(* Unhandled events *)
|
|
| `App_did_enter_background ->
|
|
`Unknown "`App_did_enter_background"
|
|
| `App_did_enter_foreground ->
|
|
`Unknown "`App_did_enter_foreground "
|
|
| `App_low_memory -> `Unknown "`App_low_memory "
|
|
| `App_terminating -> `Unknown "`App_terminating "
|
|
| `App_will_enter_background ->
|
|
`Unknown "`App_will_enter_background "
|
|
| `App_will_enter_foreground ->
|
|
`Unknown "`App_will_enter_foreground "
|
|
| `Clipboard_update -> `Unknown "`Clipboard_update "
|
|
| `Controller_axis_motion -> `Unknown "`Controller_axis_motion "
|
|
| `Controller_button_down -> `Unknown "`Controller_button_down "
|
|
| `Controller_button_up -> `Unknown "`Controller_button_up "
|
|
| `Controller_device_added ->
|
|
`Unknown "`Controller_device_added "
|
|
| `Controller_device_remapped ->
|
|
`Unknown "`Controller_device_remapped "
|
|
| `Controller_device_removed ->
|
|
`Unknown "`Controller_device_removed "
|
|
| `Dollar_gesture -> `Unknown "`Dollar_gesture "
|
|
| `Dollar_record -> `Unknown "`Dollar_record "
|
|
| `Drop_file -> `Unknown "`Drop_file "
|
|
| `Finger_down -> `Unknown "`Finger_down"
|
|
| `Finger_motion -> `Unknown "`Finger_motion "
|
|
| `Finger_up -> `Unknown "`Finger_up "
|
|
| `Joy_axis_motion -> `Unknown "`Joy_axis_motion "
|
|
| `Joy_ball_motion -> `Unknown "`Joy_ball_motion "
|
|
| `Joy_button_down -> `Unknown "`Joy_button_down "
|
|
| `Joy_button_up -> `Unknown "`Joy_button_up "
|
|
| `Joy_device_added -> `Unknown "`Joy_device_added "
|
|
| `Joy_device_removed -> `Unknown "`Joy_device_removed "
|
|
| `Joy_hat_motion -> `Unknown "`Joy_hat_motion "
|
|
| `Mouse_button_down -> `Unknown "`Mouse_button_down "
|
|
| `Mouse_button_up -> `Unknown "`Mouse_button_up"
|
|
| `Mouse_wheel -> `Unknown "`Mouse_wheel "
|
|
| `Multi_gesture -> `Unknown "`Multi_gesture"
|
|
| `Sys_wm_event -> `Unknown "`Sys_wm_event "
|
|
| `Unknown e -> `Unknown (Format.sprintf "`Unknown %d " e)
|
|
| `User_event -> `Unknown "`User_event "
|
|
| `Display_event -> `Unknown "`Display_event "
|
|
| `Sensor_update -> `Unknown "`Sensor_update "
|
|
| `Window_event -> `Unknown "`Window_event " in
|
|
(* F.epr "event_of_sdlevent: %s@." (to_string r) ;*)
|
|
r
|
|
|
|
let key_up : Sdl.keycode = 0x40000052
|
|
let key_down : Sdl.keycode = 0x40000051
|
|
let key_left : Sdl.keycode = 0x40000050
|
|
let key_right : Sdl.keycode = 0x4000004f
|
|
let handle_keyevents (el : events) f = List.iter f el
|
|
end
|
|
|
|
module Display = struct
|
|
open Tgles2
|
|
open Tsdl
|
|
open Gg
|
|
open Wall
|
|
module I = Image
|
|
module P = Path
|
|
module Text = Wall_text
|
|
|
|
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
|
|
; wall: Wall.renderer }
|
|
|
|
(* the box2 here is cannonically the place the returner drew
|
|
(the Wall.image extents) *)
|
|
type image = box2 * Wall.image
|
|
type pane = state -> state * image
|
|
type actor = (Event.events -> pane Lwt.t) ref
|
|
|
|
let pane_empty s =
|
|
(s, (Box2.of_pts (Box2.o s.box) (Box2.o s.box), Image.empty))
|
|
|
|
type frame =
|
|
{ sdl_win: Sdl.window
|
|
; gl: Sdl.gl_context
|
|
; wall: Wall.renderer
|
|
; mutable last_pane: pane
|
|
; mutable quit: bool
|
|
; mutable fullscreen: bool }
|
|
|
|
let ticks () = Int32.to_float (Sdl.get_ticks ()) /. 1000.
|
|
|
|
let on_failure ~cleanup result =
|
|
(match result with Ok _ -> () | Error _ -> cleanup ()) ;
|
|
result
|
|
|
|
let video_initialized = lazy (Sdl.init Sdl.Init.video)
|
|
|
|
let make_frame ?(title = "komm") ~w ~h () =
|
|
Lazy.force video_initialized
|
|
>>>= fun () ->
|
|
Sdl.create_window ~w ~h title
|
|
Sdl.Window.(
|
|
opengl + allow_highdpi + resizable (*+ input_grabbed*))
|
|
>>>= fun sdl_win ->
|
|
Sdl.set_window_title sdl_win title ;
|
|
ignore (Sdl.gl_set_swap_interval (-1)) ;
|
|
ignore (Sdl.gl_set_attribute Sdl.Gl.stencil_size 1) ;
|
|
on_failure
|
|
( Sdl.gl_create_context sdl_win
|
|
>>>= fun gl ->
|
|
let wall =
|
|
Wall.Renderer.create ~antialias:true ~stencil_strokes:true ()
|
|
in
|
|
Ok
|
|
{ sdl_win
|
|
; gl
|
|
; wall
|
|
; quit= false
|
|
; fullscreen= false
|
|
; last_pane= pane_empty } )
|
|
~cleanup:(fun () -> Sdl.destroy_window sdl_win)
|
|
|
|
let handle_frame_events frame events =
|
|
List.iter
|
|
(fun (e : Event.t) ->
|
|
match e with
|
|
| `Quit -> frame.quit <- true
|
|
| `Fullscreen a ->
|
|
frame.fullscreen <- a ;
|
|
ignore (Sdl.show_cursor (not frame.fullscreen) : _ result) ;
|
|
ignore
|
|
( Sdl.set_window_fullscreen frame.sdl_win
|
|
( if frame.fullscreen then
|
|
Sdl.Window.fullscreen_desktop
|
|
else Sdl.Window.windowed )
|
|
: _ result )
|
|
| _ -> () )
|
|
events
|
|
|
|
let draw_pane frame pane =
|
|
let width, height = Sdl.gl_get_drawable_size frame.sdl_win in
|
|
let _, (_, image) =
|
|
pane
|
|
{ box= Box2.v (P2.v 0. 0.) (P2.v (float width) (float height))
|
|
; time= ticks ()
|
|
; wall= frame.wall } in
|
|
Sdl.gl_make_current frame.sdl_win frame.gl
|
|
>>>= fun () ->
|
|
Gl.viewport 0 0 width height ;
|
|
Gl.clear_color 0.0 0.0 0.0 1.0 ;
|
|
Gl.(
|
|
clear
|
|
(color_buffer_bit lor depth_buffer_bit lor stencil_buffer_bit)) ;
|
|
Gl.enable Gl.blend ;
|
|
Gl.blend_func_separate Gl.one Gl.src_alpha Gl.one
|
|
Gl.one_minus_src_alpha ;
|
|
Gl.enable Gl.cull_face_enum ;
|
|
Gl.disable Gl.depth_test ;
|
|
let width = float width and height = float height in
|
|
Wall.Renderer.render frame.wall ~width ~height image ;
|
|
Sdl.gl_swap_window frame.sdl_win ;
|
|
Ok ()
|
|
|
|
let rec get_events () : Event.t list =
|
|
(* create and fill event list *)
|
|
let ev = Sdl.Event.create () in
|
|
if Sdl.poll_event (Some ev) then
|
|
get_events () @ [Event.event_of_sdlevent ev]
|
|
else []
|
|
|
|
let successful_actor = ref (fun _ -> Lwt.return pane_empty)
|
|
|
|
let display_frame frame (actor : actor) =
|
|
let events = get_events () in
|
|
handle_frame_events frame events ;
|
|
if List.length events > 0 then (
|
|
(* recompute the actor definition with the new events to return a new pane *)
|
|
( try
|
|
!actor events
|
|
>|= fun p ->
|
|
successful_actor := !actor ;
|
|
p
|
|
with e ->
|
|
F.epr
|
|
"Display.display_frame (!actor events) failed with:@. %s \
|
|
@."
|
|
(Printexc.to_string e) ;
|
|
actor := !successful_actor ;
|
|
!actor events )
|
|
>>= fun p ->
|
|
frame.last_pane <- p ;
|
|
(* call draw_pane because we should redraw now that we have updated *)
|
|
ignore (draw_pane frame frame.last_pane) ;
|
|
Lwt.return_unit )
|
|
else Lwt.return_unit
|
|
|
|
let run frame actor () =
|
|
let frame = get_result frame in
|
|
Sdl.show_window frame.sdl_win ;
|
|
let rec loop () =
|
|
Lwt.pause () (* seems required for the irc connection to work *)
|
|
>>= fun () ->
|
|
Lwt_unix.sleep 0.030
|
|
>>= fun () ->
|
|
display_frame frame actor
|
|
>>= fun () ->
|
|
if not frame.quit then loop () else Lwt.return_unit in
|
|
Lwt_main.run (loop ()) ;
|
|
print_endline "quit" ;
|
|
Sdl.hide_window frame.sdl_win ;
|
|
Sdl.gl_delete_context frame.gl ;
|
|
Sdl.destroy_window frame.sdl_win ;
|
|
Sdl.quit () ;
|
|
()
|
|
|
|
let gray ?(a = 1.0) v = Color.v v v v a
|
|
|
|
let load_font name =
|
|
let ic = open_in_bin name in
|
|
let dim = in_channel_length ic in
|
|
let fd = Unix.descr_of_in_channel ic in
|
|
let buffer =
|
|
Unix.map_file fd Bigarray.int8_unsigned Bigarray.c_layout false
|
|
[|dim|]
|
|
|> Bigarray.array1_of_genarray in
|
|
let offset = List.hd (Stb_truetype.enum buffer) in
|
|
match Stb_truetype.init buffer offset with
|
|
| None -> assert false
|
|
| 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")
|
|
let font_sans_light = lazy (load_font "fonts/Roboto-Light.ttf")
|
|
let font_sans_italic = lazy (load_font "fonts/Roboto-Italic.ttf")
|
|
|
|
let font_sans_bold_italic =
|
|
lazy (load_font "fonts/Roboto-BoldItalic.ttf")
|
|
|
|
let font_serif =
|
|
lazy (load_font "fonts/ScheherazadeNew-Regular.ttf")
|
|
|
|
let font_serif_bold =
|
|
lazy (load_font "fonts/ScheherazadeNew-Bold.ttf")
|
|
|
|
let font_mono = lazy (load_font "fonts/static/RobotoMono-Regular")
|
|
|
|
let font_mono_bold =
|
|
lazy (load_font "fonts/static/RobotoMono-Regular")
|
|
|
|
let font_mono_light =
|
|
lazy (load_font "fonts/static/RobotoMono-Regular")
|
|
|
|
let font_emoji = lazy (load_font "fonts/NotoEmoji-Regular.ttf")
|
|
|
|
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 draw_label text b =
|
|
let f = Text.Font.make ~size:(Box2.h b) (Lazy.force font_sans) in
|
|
( Box2.v (Box2.o b) (P2.v (Text.Font.text_width f text) (Box2.h b))
|
|
, I.paint
|
|
(Paint.color (gray ~a:0.5 1.0))
|
|
Text.(
|
|
simple_text f ~valign:`BASELINE ~halign:`LEFT ~x:(Box2.ox b)
|
|
~y:(Box2.oy b +. (Box2.h b *. 0.75))
|
|
text) )
|
|
|
|
let fill_box c b =
|
|
( b
|
|
, I.paint (Paint.color c)
|
|
( I.fill_path
|
|
@@ fun t ->
|
|
P.rect t ~x:(Box2.ox b) ~y:(Box2.oy b) ~w:(Box2.w b)
|
|
~h:(Box2.h b) ) )
|
|
|
|
let draw_filled_box c (s : state) = (s, fill_box c s.box)
|
|
|
|
let path_box c b (s : state) =
|
|
( s
|
|
, ( b
|
|
, I.paint (Paint.color c)
|
|
( I.stroke_path (Outline.make ())
|
|
@@ fun t ->
|
|
P.rect t ~x:(Box2.ox b) ~y:(Box2.oy b) ~w:(Box2.w b)
|
|
~h:(Box2.h b) ) ) )
|
|
|
|
let path_circle c b (s : state) =
|
|
( s
|
|
, ( b
|
|
, I.paint (Paint.color c)
|
|
( I.stroke_path (Outline.make ())
|
|
@@ fun t ->
|
|
P.circle t ~cx:(Box2.midx b) ~cy:(Box2.midy b)
|
|
~r:(Box2.w b /. 2.) ) ) )
|
|
|
|
(** Display.state.box as supplied to a widget defines the allowed drawing area for the widget.
|
|
This way basic widgets will just expand to the full area of a box, while other widgets can have
|
|
the express purpose of limiting the size of an object in a larger system of limitations.
|
|
|
|
Panes return a tuple: (state, (box, image))
|
|
state is the updated state, where state.box is always
|
|
- the top left corner of the box the pane drew in, and
|
|
- the bottom right corner of the state.box that was passed in
|
|
box is the area the widget actually drew in (or wants to sort of "use")
|
|
image is the Wall.image to compose with other panes and draw to the display
|
|
*)
|
|
|
|
let simple_text f text (s : state) =
|
|
let fm = Text.Font.font_metrics f in
|
|
let font_height = fm.ascent -. fm.descent +. fm.line_gap in
|
|
let tm = Text.Font.text_measure f text in
|
|
let br_pt =
|
|
P2.v (Box2.ox s.box +. tm.width) (Box2.oy s.box +. font_height)
|
|
in
|
|
let bextent = Box2.of_pts (Box2.o s.box) br_pt in
|
|
(* let _, (_, redbox) = path_box Color.red bextent s in*)
|
|
( {s with box= Box2.of_pts (Box2.br_pt bextent) (Box2.max s.box)}
|
|
, ( bextent
|
|
, (* I.stack redbox *)
|
|
I.paint
|
|
(Paint.color (gray ~a:0.5 1.0))
|
|
Text.(
|
|
simple_text f ~valign:`BASELINE ~halign:`LEFT
|
|
~x:(Box2.ox s.box)
|
|
~y:(Box2.oy s.box +. fm.ascent)
|
|
text) ) )
|
|
|
|
let pane_box next_point_func (subpanes : pane list) (so : state) =
|
|
let sr, (br, ir) =
|
|
List.fold_left
|
|
(fun (sp, (bp, ip)) (pane : pane) ->
|
|
(* uses br to hold max extent of boxes *)
|
|
let sr, (br, ir) = pane sp in
|
|
(* draw the pane *)
|
|
let _, (_, irb) = path_box Color.blue br sr in
|
|
(* draw the box around the pane *)
|
|
( { sr with
|
|
box= Box2.of_pts (next_point_func br) (Box2.max sp.box)
|
|
}
|
|
, ( Box2.of_pts (Box2.o bp)
|
|
(P2.v
|
|
(max (Box2.maxx br) (Box2.maxx bp))
|
|
(max (Box2.maxy br) (Box2.maxy bp)) )
|
|
, Image.seq [ip; irb; ir] ) ) )
|
|
( so
|
|
, (Box2.of_pts (Box2.o so.box) (Box2.o so.box), Image.empty)
|
|
)
|
|
subpanes in
|
|
let _, (_, redbox) = path_box Color.red br sr in
|
|
(sr, (br, Image.stack redbox ir))
|
|
end
|
|
|
|
module Panel = struct
|
|
open Display
|
|
open Gg
|
|
|
|
type t =
|
|
{ mutable act: t -> Event.events -> Display.pane Lwt.t
|
|
; mutable subpanels: t Lwt.t list
|
|
; mutable tag: string }
|
|
|
|
let blank =
|
|
{ act= (fun _panel _events -> Lwt.return Display.pane_empty)
|
|
; subpanels= []
|
|
; tag= "blank pane" }
|
|
|
|
let draw (pane : Display.pane) =
|
|
Lwt.return
|
|
{ act= (fun _panel _events -> Lwt.return pane)
|
|
; subpanels= []
|
|
; tag= "draw-pane" }
|
|
|
|
let actor (panel : t) : Event.events -> Display.pane Lwt.t =
|
|
fun events ->
|
|
panel.act panel events >>= fun pane -> Lwt.return pane
|
|
|
|
let filter_events ef p =
|
|
p
|
|
>>= fun p' ->
|
|
Lwt.return
|
|
{p' with act= (fun panel events -> p'.act panel (ef events))}
|
|
|
|
let resolve_panels events =
|
|
Lwt_list.map_s (fun s ->
|
|
s
|
|
>>= fun subpanel ->
|
|
subpanel.act subpanel events >>= fun pane -> Lwt.return pane )
|
|
|
|
(* draws subsequent items below *)
|
|
let vbox subpanels =
|
|
Lwt.return
|
|
{ act=
|
|
(fun panel events ->
|
|
resolve_panels events panel.subpanels
|
|
>|= fun pl -> pane_box Box2.tl_pt pl )
|
|
(* tl_pt is actually bl_pt in the Wall coordinate system *)
|
|
; subpanels
|
|
; tag= "vertical-box" }
|
|
|
|
(* draws subsequent item to the right *)
|
|
let hbox subpanels =
|
|
Lwt.return
|
|
{ act=
|
|
(fun panel events ->
|
|
resolve_panels events panel.subpanels
|
|
>|= fun pl -> pane_box Box2.br_pt pl )
|
|
(* br_pt is actually tr_pt in the Wall coordinate system *)
|
|
; subpanels
|
|
; tag= "horizontal-box" }
|
|
|
|
(* draws subsequent panels overtop each other *)
|
|
let obox (subpanels : t Lwt.t list) =
|
|
{ act=
|
|
(fun panel events ->
|
|
resolve_panels events panel.subpanels
|
|
>|= fun pl -> pane_box Box2.o pl )
|
|
; subpanels
|
|
; tag= "origin-box" }
|
|
|
|
let g_text_height = ref 25.
|
|
|
|
type Format.stag += Color_bg of Wall.color
|
|
type Format.stag += Color_fg of Wall.color
|
|
type Format.stag += Cursor of Wall.color
|
|
type Format.stag += None_tag
|
|
|
|
let draw_pp height fpp (s : state) =
|
|
let node, sc, box = (ref I.empty, ref s, ref Box2.zero) in
|
|
let push (s, (b, i)) =
|
|
node := I.stack !node i ;
|
|
sc := s ;
|
|
box := b in
|
|
let font = Text.Font.make ~size:height (Lazy.force font_sans) in
|
|
let fm = Text.Font.font_metrics font in
|
|
let font_height = fm.ascent -. fm.descent +. fm.line_gap in
|
|
let max_x = ref 0. in
|
|
let out_string text o l =
|
|
let sp = !sc in
|
|
push @@ simple_text font (String.sub text o l) !sc ;
|
|
max_x := max !max_x (Box2.maxx !box) ;
|
|
sc :=
|
|
{ !sc with
|
|
box=
|
|
Box2.of_pts
|
|
(P2.v (Box2.maxx !box) (Box2.oy sp.box))
|
|
(Box2.max sp.box) } in
|
|
let out_flush () = () in
|
|
let out_newline () =
|
|
sc :=
|
|
{ !sc with
|
|
box=
|
|
Box2.of_pts
|
|
(P2.v (Box2.ox s.box) (Box2.oy !sc.box +. font_height))
|
|
(Box2.max s.box) } in
|
|
let out_spaces n =
|
|
let wpx = Text.Font.text_width font " " in
|
|
if Box2.ox !sc.box +. (float n *. wpx) > Box2.maxx !sc.box then
|
|
(* WRAP *)
|
|
out_newline () ;
|
|
let so = !sc in
|
|
(* let bsp = Box2.v (Box2.br_pt !box) (P2.v wpx height) in
|
|
push @@ pane_hbox (List.init n (fun _ -> path_circle Color.green bsp)) !sc;*)
|
|
box := Box2.v (Box2.o so.box) (P2.v (float n *. wpx) height) ;
|
|
sc :=
|
|
{!sc with box= Box2.of_pts (Box2.br_pt !box) (Box2.max so.box)}
|
|
in
|
|
let out_indent n =
|
|
let p = min (Box2.w !sc.box -. 1.) (height *. 2.0 *. float n) in
|
|
sc :=
|
|
{ !sc with
|
|
box=
|
|
Box2.of_pts
|
|
(P2.v (Box2.ox !sc.box +. p) (Box2.oy !sc.box))
|
|
(Box2.max !sc.box) } in
|
|
let out_funs =
|
|
Format.
|
|
{out_string; out_flush; out_newline; out_spaces; out_indent}
|
|
in
|
|
let pp = Format.formatter_of_out_functions out_funs in
|
|
Format.pp_set_formatter_stag_functions pp
|
|
{ mark_open_stag=
|
|
(fun s ->
|
|
( match s with
|
|
| Cursor c ->
|
|
push
|
|
@@ ( !sc
|
|
, fill_box c
|
|
(Box2.v (Box2.o !sc.box)
|
|
(P2.v (height *. 0.333) height) ) )
|
|
| Color_bg c -> push @@ (!sc, fill_box c !box)
|
|
| _ -> () ) ;
|
|
"" )
|
|
; mark_close_stag= (function _ -> () ; "")
|
|
; print_open_stag= (fun _ -> (*"<open_stag>"*) ())
|
|
; (* TKTKTKTK XXX IT SHOULD BE USING THESE print ONES *)
|
|
print_close_stag= (fun _ -> (*"<close_stag>"*) ()) } ;
|
|
Format.pp_set_tags pp true ;
|
|
let margin =
|
|
int_of_float (Box2.w s.box /. Text.Font.text_width font " ")
|
|
in
|
|
let max_indent = margin - 1 in
|
|
Format.pp_safe_set_geometry pp ~max_indent ~margin ;
|
|
fpp pp ;
|
|
Format.pp_force_newline pp () ;
|
|
( !sc
|
|
, ( Box2.of_pts (Box2.o s.box) (P2.v !max_x (Box2.maxy !box))
|
|
, !node ) )
|
|
|
|
let format_symbolic_output_items (ppf : Format.formatter) buf =
|
|
List.iter
|
|
Format.(
|
|
function
|
|
| Output_flush -> F.pf ppf "@?"
|
|
| Output_newline -> F.pf ppf "@."
|
|
| Output_string s -> Format.pp_print_string ppf s
|
|
| Output_spaces n | Output_indent n ->
|
|
Format.pp_print_string ppf (String.make n ' '))
|
|
buf
|
|
|
|
let format_symbolic_output_buffer (ppf : Format.formatter) buf =
|
|
format_symbolic_output_items ppf
|
|
(Format.get_symbolic_output_buffer buf)
|
|
|
|
let prettyprint ?(height = !g_text_height) ?(tag = "pretty-print")
|
|
fpp =
|
|
Lwt.return
|
|
{ act= (fun _panel _events -> Lwt.return (draw_pp height fpp))
|
|
; subpanels= []
|
|
; tag }
|
|
|
|
module Textedit = struct
|
|
type t =
|
|
{ mutable zed: unit Zed_edit.context
|
|
; mutable view: Zed_cursor.t
|
|
; mutable keybind: Input.Bind.state }
|
|
|
|
let bindings te =
|
|
let open Input.Bind in
|
|
add [([], Code Left)] [Zed Prev_char]
|
|
@@ add [([], Code Right)] [Zed Next_char]
|
|
@@ add [([], Code Up)] [Zed Prev_line]
|
|
@@ add [([], Code Down)] [Zed Next_line]
|
|
@@ add [([], Code Home)] [Zed Goto_bol]
|
|
@@ add [([], Code End)] [Zed Goto_eol]
|
|
@@ add [([], Code Insert)] [Zed Switch_erase_mode]
|
|
@@ add [([], Code Delete)] [Zed Delete_next_char]
|
|
@@ add [([], Code Enter)] [Zed Newline]
|
|
@@ add [([Ctrl], Char ' ')] [Zed Set_mark]
|
|
@@ add [([Ctrl], Char 'a')] [Zed Goto_bol]
|
|
@@ add [([Ctrl], Char 'e')] [Zed Goto_eol]
|
|
@@ add [([Ctrl], Char 'd')] [Zed Delete_next_char]
|
|
@@ add [([Ctrl], Char 'h')] [Zed Delete_prev_char]
|
|
@@ add [([Ctrl], Char 'k')] [Zed Kill_next_line]
|
|
@@ add [([Ctrl], Char 'u')] [Zed Kill_prev_line]
|
|
@@ add [([Ctrl], Char 'n')] [Zed Next_line]
|
|
@@ add [([Ctrl], Char 'p')] [Zed Prev_line]
|
|
@@ add [([Ctrl], Char 'w')] [Zed Kill]
|
|
@@ add [([Ctrl], Char 'y')] [Zed Yank]
|
|
@@ add [([], Code Backspace)] [Zed Delete_prev_char]
|
|
@@ add [([Meta], Char 'w')] [Zed Copy]
|
|
@@ add [([Meta], Char 'c')] [Zed Capitalize_word]
|
|
@@ add [([Meta], Char 'l')] [Zed Lowercase_word]
|
|
@@ add [([Meta], Char 'u')] [Zed Uppercase_word]
|
|
@@ add [([Meta], Char 'b')] [Zed Prev_word]
|
|
@@ add [([Meta], Char 'f')] [Zed Next_word]
|
|
@@ add [([Meta], Code Right)] [Zed Next_word]
|
|
@@ add [([Meta], Code Left)] [Zed Prev_word]
|
|
@@ add [([Ctrl], Code Right)] [Zed Next_word]
|
|
@@ add [([Ctrl], Code Left)] [Zed Prev_word]
|
|
@@ add [([Meta], Code Backspace)] [Zed Kill_prev_word]
|
|
@@ add [([Meta], Code Delete)] [Zed Kill_prev_word]
|
|
@@ add [([Ctrl], Code Delete)] [Zed Kill_next_word]
|
|
@@ add [([Meta], Char 'd')] [Zed Kill_next_word]
|
|
@@ add [([Ctrl], Char '/')] [Zed Undo]
|
|
@@ add [([Ctrl], Char 'x'); ([], Char 'u')] [Zed Undo]
|
|
@@ add
|
|
[([Ctrl], Char 'v')]
|
|
[ Custom
|
|
(fun () ->
|
|
let r = Zed_edit.text (Zed_edit.edit te.zed) in
|
|
let l = Zed_lines.of_rope r in
|
|
let i = Zed_cursor.get_line te.view in
|
|
Zed_cursor.goto te.view
|
|
(Zed_lines.line_start l i + 10) ) ]
|
|
@@ add
|
|
[([Meta], Char 'v')]
|
|
[ Custom
|
|
(fun () ->
|
|
let r = Zed_edit.text (Zed_edit.edit te.zed) in
|
|
let l = Zed_lines.of_rope r in
|
|
let i = Zed_cursor.get_line te.view in
|
|
Zed_cursor.goto te.view
|
|
(Zed_lines.line_start l i - 10) ) ]
|
|
@@ empty
|
|
|
|
let clear te =
|
|
let ze = Zed_edit.create () in
|
|
te.zed <- Zed_edit.context ze (Zed_edit.new_cursor ze)
|
|
|
|
let insert te text =
|
|
Zed_edit.insert te.zed
|
|
(Zed_rope.of_string (Zed_string.of_utf8 text))
|
|
|
|
let contents (te : t) =
|
|
Zed_string.to_utf8
|
|
(Zed_rope.to_string (Zed_edit.text (Zed_edit.edit te.zed)))
|
|
|
|
let make ?(keybinds = bindings) initialtext () =
|
|
let ze = Zed_edit.create () in
|
|
let te =
|
|
{ zed= Zed_edit.context ze (Zed_edit.new_cursor ze)
|
|
; view= Zed_edit.new_cursor ze
|
|
; keybind= Input.Bind.init Input.Bind.empty } in
|
|
te.keybind.bindings <- keybinds te ;
|
|
insert te initialtext ;
|
|
te
|
|
|
|
let panel ?(height = !g_text_height) te =
|
|
Lwt.return
|
|
{ act=
|
|
(fun _panel events ->
|
|
(* collect events and update Zed context *)
|
|
Lwt_list.iter_s
|
|
(function
|
|
| `Key_down (k : Input.keystate) -> (
|
|
let open Input.Bind in
|
|
( match te.keybind.state with
|
|
| Accepted _ | Rejected ->
|
|
te.keybind.last_keyseq <- [] ;
|
|
te.keybind.last_actions <- []
|
|
| Continue _ -> () ) ;
|
|
te.keybind.state <-
|
|
resolve k
|
|
(get_resolver te.keybind.state
|
|
(default_resolver te.keybind.bindings) ) ;
|
|
te.keybind.last_keyseq <-
|
|
k :: te.keybind.last_keyseq ;
|
|
match te.keybind.state with
|
|
| Accepted a ->
|
|
te.keybind.last_actions <- a ;
|
|
Lwt_list.iter_s
|
|
(function
|
|
| Input.Bind.Custom f ->
|
|
Lwt.return (f ())
|
|
| Input.Bind.CustomLwt f -> f ()
|
|
| Zed za ->
|
|
Lwt.return
|
|
(Zed_edit.get_action za te.zed) )
|
|
a
|
|
| Continue _ | Rejected -> Lwt.return_unit )
|
|
| `Key_up _ -> Lwt.return_unit
|
|
| `Text_input s ->
|
|
Lwt.return
|
|
(Zed_edit.insert te.zed
|
|
(Zed_rope.of_string (Zed_string.of_utf8 s)) )
|
|
| _ -> Lwt.return_unit )
|
|
events
|
|
>>= fun () ->
|
|
let draw_textedit =
|
|
draw_pp height (fun pp ->
|
|
let _, view =
|
|
Zed_rope.break
|
|
(Zed_edit.text (Zed_edit.edit te.zed))
|
|
(Zed_cursor.get_position te.view) in
|
|
Format.pp_open_hvbox pp 0 ;
|
|
if
|
|
Zed_cursor.get_position te.view
|
|
> Zed_cursor.get_position
|
|
(Zed_edit.cursor te.zed)
|
|
then (
|
|
let zrb, zra =
|
|
Zed_rope.break
|
|
(Zed_edit.text (Zed_edit.edit te.zed))
|
|
(Zed_cursor.get_position
|
|
(Zed_edit.cursor te.zed) ) 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
|
|
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 )
|
|
else
|
|
F.text pp
|
|
(Zed_string.to_utf8 (Zed_rope.to_string view)) ;
|
|
F.pf pp "@." ;
|
|
Format.pp_close_box pp () ) in
|
|
Lwt.return draw_textedit )
|
|
; subpanels= []
|
|
; tag= "textedit" }
|
|
|
|
(* pane that displays last key binding match state *)
|
|
let bindingstate ?(height = !g_text_height) (b : Input.Bind.state)
|
|
=
|
|
Lwt.return
|
|
{ act=
|
|
(fun _panel _events ->
|
|
Lwt.return
|
|
(draw_pp height (fun pp ->
|
|
Format.pp_open_hbox pp () ;
|
|
F.text pp
|
|
(List.fold_left
|
|
(fun s x ->
|
|
Input.to_string_compact x ^ " " ^ s )
|
|
"" b.last_keyseq ) ;
|
|
F.text pp "-> " ;
|
|
F.text pp
|
|
( match b.state with
|
|
| Accepted a ->
|
|
"Accepted "
|
|
^ List.fold_right
|
|
(fun x s ->
|
|
s
|
|
^ Input.Bind.(
|
|
match x with
|
|
| Zed a ->
|
|
Zed_edit.name_of_action a
|
|
| CustomLwt _ -> "CustomLwt"
|
|
| Custom _ -> "Custom")
|
|
^ "; " )
|
|
a ""
|
|
| Rejected -> "Rejected"
|
|
| Continue _ -> "Continue" ) ;
|
|
Format.pp_close_box pp () ;
|
|
F.flush pp () ) ) )
|
|
; subpanels= []
|
|
; tag= "binding-state" }
|
|
end
|
|
|
|
module Modal = struct
|
|
type t =
|
|
{ te: Textedit.t
|
|
; mutable input: string option
|
|
; mutable handle: string -> unit
|
|
; mutable prompt: string }
|
|
|
|
let make () =
|
|
{ te= Textedit.make "" ()
|
|
; input= None
|
|
; handle= (fun _text -> ())
|
|
; prompt= "" }
|
|
|
|
let panel ?(height = !g_text_height) me =
|
|
let keybinds =
|
|
let open Input.Bind in
|
|
add [([], Code Enter)]
|
|
[ Custom
|
|
(fun () ->
|
|
(* set input first so a modal can trigger another modal *)
|
|
me.input <- None ;
|
|
me.handle (Textedit.contents me.te) ) ]
|
|
(Textedit.bindings me.te) in
|
|
me.te.keybind.bindings <- keybinds ;
|
|
Lwt.return
|
|
{ act=
|
|
(fun panel events ->
|
|
match me.input with
|
|
| Some text ->
|
|
Textedit.insert me.te text ;
|
|
hbox panel.subpanels >>= fun p -> p.act panel events
|
|
| None -> Lwt.return Display.pane_empty
|
|
(* don't draw anything if modal isn't active *) )
|
|
; subpanels=
|
|
[ prettyprint (fun pp -> F.text pp me.prompt)
|
|
; Textedit.panel ~height me.te ]
|
|
; tag= "modal-edit" }
|
|
|
|
let start me ?(prompt = "> ") text handler =
|
|
me.input <- Some text ;
|
|
Textedit.clear me.te ;
|
|
Textedit.insert me.te text ;
|
|
me.handle <- handler ;
|
|
me.prompt <- prompt
|
|
|
|
let is_active me =
|
|
match me.input with Some _ -> true | None -> false
|
|
end
|
|
|
|
module Nottui = struct
|
|
open Nottui
|
|
module P = Nottui_pretty
|
|
|
|
let convert_events events : Nottui_lwt.event option list =
|
|
let key_of_keystate
|
|
(Input.{ctrl; meta; shift; super= _; code} as k) :
|
|
Notty.Unescape.key option =
|
|
F.epr "Nottui.convert_events: %s@."
|
|
(Input.to_string_compact k) ;
|
|
match code with
|
|
| None | Unknown -> None
|
|
| code ->
|
|
Some
|
|
( ( match code with
|
|
| UChar c ->
|
|
let d =
|
|
Uchar.of_int (CamomileLibrary.UChar.code c)
|
|
in
|
|
if Uchar.is_char d then `ASCII (Uchar.to_char d)
|
|
else `Uchar d
|
|
| Enter -> `Enter
|
|
| Escape -> `Escape
|
|
| Tab -> `Tab
|
|
| Up -> `Arrow `Up
|
|
| Down -> `Arrow `Down
|
|
| Left -> `Arrow `Left
|
|
| Right -> `Arrow `Right
|
|
| F1 -> `Function 1
|
|
| F2 -> `Function 2
|
|
| F3 -> `Function 3
|
|
| F4 -> `Function 4
|
|
| F5 -> `Function 5
|
|
| F6 -> `Function 6
|
|
| F7 -> `Function 7
|
|
| F8 -> `Function 8
|
|
| F9 -> `Function 9
|
|
| F10 -> `Function 10
|
|
| F11 -> `Function 11
|
|
| F12 -> `Function 12
|
|
| Next_page -> `Page `Down
|
|
| Prev_page -> `Page `Up
|
|
| Home -> `Home
|
|
| End -> `End
|
|
| Insert -> `Insert
|
|
| Delete -> `Delete
|
|
| Backspace -> `Backspace
|
|
| _ -> `Uchar (Uchar.of_int 0) )
|
|
, (if ctrl then [`Ctrl] else [])
|
|
@ (if meta then [`Meta] else [])
|
|
@ if shift then [`Shift] else [] ) in
|
|
List.filter_map
|
|
(function
|
|
| `Key_down k -> (
|
|
match key_of_keystate k with
|
|
| None -> None
|
|
| Some k -> Some (Some (`Key k)) )
|
|
| _ -> None )
|
|
events
|
|
|
|
module Attr = struct
|
|
type attr =
|
|
{ fg: Wall.color
|
|
; bg: Wall.color
|
|
; size: float
|
|
; font: [`Sans | `Serif | `Mono]
|
|
; weight: [`Bold | `Regular | `Light]
|
|
; italic: [`Italic | `None]
|
|
; underline: [`Underline | `None] }
|
|
|
|
let empty =
|
|
{ fg= Color.void
|
|
; bg= Color.void
|
|
; size= 0.
|
|
; font= `Sans
|
|
; weight= `Regular
|
|
; italic= `None
|
|
; underline= `None }
|
|
|
|
let equal = ( == )
|
|
|
|
let ( ++ ) a1 a2 =
|
|
if a1 == empty then a2
|
|
else if a2 == empty then a1
|
|
else
|
|
{ a1 with
|
|
fg= Color.blend a1.fg a2.fg
|
|
; bg= Color.blend a1.bg a2.bg }
|
|
|
|
let fg fg = {empty with fg}
|
|
let bg bg = {empty with bg}
|
|
|
|
let get_font a =
|
|
Text.Font.make ~size:a.size
|
|
(load_font
|
|
( match (a.font, a.weight, a.italic) with
|
|
| `Sans, `Regular, `None -> "fonts/Roboto-Regular.ttf"
|
|
| `Sans, `Bold, `None -> "fonts/Roboto-Bold.ttf"
|
|
| `Sans, `Light, `None -> "fonts/Roboto-Light.ttf"
|
|
| `Sans, `Regular, `Italic -> "fonts/Roboto-Italic.ttf"
|
|
| `Sans, `Bold, `Italic -> "fonts/Roboto-BoldItalic.ttf"
|
|
| `Sans, `Light, `Italic ->
|
|
"fonts/Roboto-LightItalic.ttf"
|
|
| `Serif, `Bold, _ -> "fonts/ScheherazadeNew-Bold.ttf"
|
|
| `Serif, _, _ -> "fonts/ScheherazadeNew-Regular.ttf"
|
|
| `Mono, `Regular, `None ->
|
|
"fonts/static/RobotoMono-Regular.ttf"
|
|
| _, _, _ -> "fonts/Roboto-Regular.ttf" ) )
|
|
end
|
|
|
|
let invalid_arg fmt = Format.kasprintf invalid_arg fmt
|
|
let ( &. ) f g x = f (g x)
|
|
let btw (x : int) a b = a <= x && x <= b
|
|
let bit n b = b land (1 lsl n) > 0
|
|
let max (a : int) b = if a > b then a else b
|
|
let min (a : int) b = if a < b then a else b
|
|
|
|
let is_C0 x = x < 0x20 || x = 0x7f
|
|
and is_C1 x = 0x80 <= x && x < 0xa0
|
|
|
|
let is_ctrl x = is_C0 x || is_C1 x and is_ascii x = x < 0x80
|
|
|
|
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 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 memo (type a) ?(hash = Hashtbl.hash) ?(eq = ( = )) ~size f =
|
|
let module H = Ephemeron.K1.Make (struct
|
|
type t = a
|
|
|
|
let hash, equal = (hash, eq)
|
|
end) in
|
|
let t = H.create size in
|
|
fun x ->
|
|
try H.find t x
|
|
with Not_found ->
|
|
let y = f x in
|
|
H.add t x y ; y
|
|
|
|
module List = struct
|
|
include List
|
|
|
|
let init n f =
|
|
let rec go a n = if n < 0 then a else go (f n :: a) (n - 1) in
|
|
go [] (n - 1)
|
|
end
|
|
|
|
module Buffer = struct
|
|
include Buffer
|
|
|
|
let buf = Buffer.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 Text = struct
|
|
let err_ctrl u =
|
|
invalid_arg "Notty: control char: U+%02X, %S" (Char.code u)
|
|
|
|
let err_malformed = invalid_arg "Notty: malformed UTF-8: %s, %S"
|
|
|
|
type t =
|
|
| Ascii of string * int * int
|
|
| Utf8 of string * int array * int * int
|
|
|
|
let equal t1 t2 =
|
|
match (t1, t2) with
|
|
| Utf8 (s1, _, i1, n1), Utf8 (s2, _, i2, n2)
|
|
|Ascii (s1, i1, n1), Ascii (s2, i2, n2) ->
|
|
i1 = i2 && n1 = n2 && s1 = s2
|
|
| _ -> false
|
|
|
|
let width = function
|
|
| Utf8 (_, _, _, w) -> w
|
|
| Ascii (_, _, w) -> w
|
|
|
|
let empty = Ascii ("", 0, 0)
|
|
|
|
let graphemes str =
|
|
let seg = Uuseg.create `Grapheme_cluster in
|
|
let rec f ((is, w) as acc) i evt =
|
|
match Uuseg.add seg evt with
|
|
| `Await | `End -> acc
|
|
| `Uchar u ->
|
|
f (is, w + Uucp.Break.tty_width_hint u) i `Await
|
|
| `Boundary ->
|
|
let is =
|
|
match w with
|
|
| 0 -> is
|
|
| 1 -> i :: is
|
|
| _ -> i :: -1 :: is in
|
|
f (is, 0) i `Await in
|
|
let acc =
|
|
Uutf.String.fold_utf_8
|
|
(fun acc i -> function
|
|
| `Malformed err -> err_malformed err str
|
|
| `Uchar _ as u -> f acc i u )
|
|
([0], 0)
|
|
str in
|
|
f acc (String.length str) `End
|
|
|> fst |> List.rev |> Array.of_list
|
|
|
|
let dead = ' '
|
|
|
|
let to_buffer buf = function
|
|
| Ascii (s, off, w) -> Buffer.add_substring buf s off w
|
|
| Utf8 (s, ix, off, w) ->
|
|
let x1 =
|
|
match ix.(off) with
|
|
| -1 ->
|
|
Buffer.add_char buf dead ;
|
|
ix.(off + 1)
|
|
| x -> x
|
|
and x2 = ix.(off + w) in
|
|
Buffer.add_substring buf s x1
|
|
@@ ((if x2 = -1 then ix.(off + w - 1) else x2) - x1) ;
|
|
if x2 = -1 then Buffer.add_char buf dead
|
|
|
|
let sub t x w =
|
|
let w1 = width t in
|
|
if w = 0 || x >= w1 then empty
|
|
else
|
|
let w = min w (w1 - x) in
|
|
if w = w1 then t
|
|
else
|
|
match t with
|
|
| Ascii (s, off, _) -> Ascii (s, off + x, w)
|
|
| Utf8 (s, ix, off, _) -> Utf8 (s, ix, off + x, w)
|
|
|
|
let is_ascii_or_raise_ctrl s =
|
|
let ( @! ) s i = String.unsafe_get s i |> Char.code in
|
|
let rec go s acc i n =
|
|
if n = 0 then acc
|
|
else
|
|
let x = s @! i in
|
|
if is_C0 x then err_ctrl s.[i] s
|
|
else if x = 0xc2 && n > 1 && is_C1 (s @! (i + 1)) then
|
|
err_ctrl s.[i + 1] s
|
|
else go s (acc && is_ascii x) (i + 1) (n - 1) in
|
|
go s true 0 (String.length s)
|
|
|
|
let of_ascii s = Ascii (s, 0, String.length s)
|
|
|
|
and of_unicode s =
|
|
let x = graphemes s in
|
|
Utf8 (s, x, 0, Array.length x - 1)
|
|
|
|
let of_unicode = memo ~eq:String.equal ~size:128 of_unicode
|
|
|
|
let of_string = function
|
|
| "" -> empty
|
|
| s ->
|
|
if is_ascii_or_raise_ctrl s then of_ascii s
|
|
else of_unicode s
|
|
|
|
let of_uchars ucs =
|
|
of_string @@ Buffer.mkstring
|
|
@@ fun buf -> Array.iter (Buffer.add_utf_8_uchar buf) ucs
|
|
|
|
let replicateu w u =
|
|
if is_ctrl (Uchar.to_int u) then
|
|
err_ctrl (Uchar.unsafe_to_char u) "<repeated character>"
|
|
else if w < 1 then empty
|
|
else if is_ascii (Uchar.to_int u) then
|
|
of_ascii (String.make w (Uchar.unsafe_to_char u))
|
|
else
|
|
of_unicode @@ Buffer.mkstring
|
|
@@ fun buf ->
|
|
for _ = 1 to w do
|
|
Buffer.add_utf_8_uchar buf u
|
|
done
|
|
|
|
let replicatec w c = replicateu w (Uchar.of_char c)
|
|
end
|
|
|
|
module I = struct
|
|
type dim = int * int
|
|
|
|
type t =
|
|
| Empty
|
|
| Segment of Text.t
|
|
| Attr of (t * Attr.attr) * dim
|
|
| Hcompose of (t * t) * dim
|
|
| Vcompose of (t * t) * dim
|
|
| Zcompose of (t * t) * dim
|
|
| Hcrop of (t * int * int) * dim
|
|
| Vcrop of (t * int * int) * dim
|
|
| Void of dim
|
|
|
|
let width = function
|
|
| Empty -> 0
|
|
| Segment text -> Text.width text
|
|
| Attr (_, (w, _)) -> w
|
|
| Hcompose (_, (w, _)) -> w
|
|
| Vcompose (_, (w, _)) -> w
|
|
| Zcompose (_, (w, _)) -> w
|
|
| Hcrop (_, (w, _)) -> w
|
|
| Vcrop (_, (w, _)) -> w
|
|
| Void (w, _) -> w
|
|
[@@inline]
|
|
|
|
let height = function
|
|
| Empty -> 0
|
|
| Segment _ -> 1
|
|
| Attr (_, (_, h)) -> h
|
|
| Hcompose (_, (_, h)) -> h
|
|
| Vcompose (_, (_, h)) -> h
|
|
| Zcompose (_, (_, h)) -> h
|
|
| Hcrop (_, (_, h)) -> h
|
|
| Vcrop (_, (_, h)) -> h
|
|
| Void (_, h) -> h
|
|
[@@inline]
|
|
|
|
let equal t1 t2 =
|
|
let rec eq t1 t2 =
|
|
match (t1, t2) with
|
|
| Empty, Empty -> true
|
|
| Segment t1, Segment t2 -> Text.equal t1 t2
|
|
| Attr ((a, a1), _), Attr ((b, a2), _) ->
|
|
Attr.equal a1 a2 && eq a b
|
|
| Hcompose ((a, b), _), Hcompose ((c, d), _)
|
|
|Vcompose ((a, b), _), Vcompose ((c, d), _)
|
|
|Zcompose ((a, b), _), Zcompose ((c, d), _) ->
|
|
eq a c && eq b d
|
|
| Hcrop ((a, i1, n1), _), Hcrop ((b, i2, n2), _)
|
|
|Vcrop ((a, i1, n1), _), Vcrop ((b, i2, n2), _) ->
|
|
i1 = i2 && n1 = n2 && eq a b
|
|
| Void (a, b), Void (c, d) -> a = c && b = d
|
|
| _ -> false in
|
|
width t1 = width t2 && height t1 = height t2 && eq t1 t2
|
|
|
|
let empty = Empty
|
|
|
|
let void w h =
|
|
if w < 1 && h < 1 then Empty else Void (max 0 w, max 0 h)
|
|
|
|
let attr a = function
|
|
| Attr ((t, a0), dim) -> Attr ((t, Attr.(a ++ a0)), dim)
|
|
| t -> Attr ((t, a), (width t, height t))
|
|
|
|
let ( <|> ) t1 t2 =
|
|
match (t1, t2) with
|
|
| _, Empty -> t1
|
|
| Empty, _ -> t2
|
|
| _ ->
|
|
let w = width t1 + width t2
|
|
and h = max (height t1) (height t2) in
|
|
Hcompose ((t1, t2), (w, h))
|
|
|
|
let ( <-> ) t1 t2 =
|
|
match (t1, t2) with
|
|
| _, Empty -> t1
|
|
| Empty, _ -> t2
|
|
| _ ->
|
|
let w = max (width t1) (width t2)
|
|
and h = height t1 + height t2 in
|
|
Vcompose ((t1, t2), (w, h))
|
|
|
|
let ( </> ) t1 t2 =
|
|
match (t1, t2) with
|
|
| _, Empty -> t1
|
|
| Empty, _ -> t2
|
|
| _ ->
|
|
let w = max (width t1) (width t2)
|
|
and h = max (height t1) (height t2) in
|
|
Zcompose ((t1, t2), (w, h))
|
|
|
|
let lincropinv crop void ( ++ ) init fini img =
|
|
match (init >= 0, fini >= 0) with
|
|
| true, true -> crop init fini img
|
|
| true, _ -> crop init 0 img ++ void (-fini)
|
|
| _, true -> void (-init) ++ crop 0 fini img
|
|
| _ -> void (-init) ++ img ++ void (-fini)
|
|
|
|
let hcrop =
|
|
let ctor left right img =
|
|
let h = height img and w = width img - left - right in
|
|
if w > 0 then Hcrop ((img, left, right), (w, h))
|
|
else void w h in
|
|
lincropinv ctor (fun w -> void w 0) ( <|> )
|
|
|
|
let vcrop =
|
|
let ctor top bottom img =
|
|
let w = width img and h = height img - top - bottom in
|
|
if h > 0 then Vcrop ((img, top, bottom), (w, h))
|
|
else void w h in
|
|
lincropinv ctor (void 0) ( <-> )
|
|
|
|
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 hcat = concatm empty ( <|> )
|
|
let vcat = concatm empty ( <-> )
|
|
let zcat xs = List.fold_right ( </> ) xs empty
|
|
|
|
let text attr tx =
|
|
match (Text.width tx, attr) with
|
|
| 0, _ -> void 0 1
|
|
| w, Some a -> Attr ((Segment tx, a), (w, 1))
|
|
| _, _ -> Segment tx
|
|
|
|
let string ?attr s = text attr (Text.of_string s)
|
|
let uchars ?attr a = text attr (Text.of_uchars a)
|
|
|
|
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)
|
|
end
|
|
|
|
(* let string ?(attr = Attr.empty) str =
|
|
let control_character_index str i =
|
|
let len = String.length str in
|
|
let i = ref i in
|
|
while
|
|
let i = !i in
|
|
i < len && str.[i] >= ' '
|
|
do
|
|
incr i
|
|
done ;
|
|
if !i = len then raise Not_found ;
|
|
!i in
|
|
let rec split str i =
|
|
match control_character_index str i with
|
|
| j ->
|
|
let img = I.string ~attr (String.sub str i (j - i)) in
|
|
img :: split str (j + 1)
|
|
| exception Not_found ->
|
|
[ I.string ~attr
|
|
( if i = 0 then str
|
|
else String.sub str i (String.length str - i) ) ]
|
|
in
|
|
Ui.atom (I.vcat (split str 0))*)
|
|
|
|
let attr_menu_main = Attr.(bg (Color.gray 0.7) ++ fg Color.black)
|
|
let attr_menu_sub = Attr.(bg (Color.gray 0.5) ++ fg Color.black)
|
|
let attr_clickable = Attr.(bg Color.blue)
|
|
|
|
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 =
|
|
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 Attr.(bg lightred) (sub' text pos 1)
|
|
; I.string attr (sub' text (pos + 1) (len - pos - 1)) ]
|
|
else [I.string Attr.(bg lightred) " "]
|
|
else
|
|
[ I.string
|
|
Attr.(st underline)
|
|
(if text = "" then " " else text) ] in
|
|
let handler = function
|
|
| `ASCII 'U', [`Ctrl] ->
|
|
on_change ("", 0) ;
|
|
`Handled (* clear *)
|
|
| `ASCII 'k', [`Ctrl] ->
|
|
on_change (String.sub text 0 pos, pos) ;
|
|
`Handled (* clear *)
|
|
| `Escape, [] | `ASCII 'n', [`Ctrl] ->
|
|
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
|
|
| `Arrow `Left, [] | `ASCII 'b', [`Ctrl] ->
|
|
if pos > 0 && pos < String.length text then (
|
|
on_change (text, pos - 1) ;
|
|
`Handled )
|
|
else `Unhandled
|
|
| `Arrow `Right, [] | `ASCII 'f', [`Ctrl] ->
|
|
let pos = pos + 1 in
|
|
if pos <= String.length text then (
|
|
on_change (text, pos) ;
|
|
`Handled )
|
|
else `Unhandled
|
|
| `ASCII 'e', [`Ctrl] ->
|
|
on_change (text, String.length text) ;
|
|
`Handled
|
|
| `ASCII 'a', [`Ctrl] ->
|
|
on_change (text, 0) ;
|
|
`Handled
|
|
| _ -> `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 )
|
|
|
|
let simple_edit s =
|
|
let var = Lwd.var (s, 0) in
|
|
edit_field (Lwd.get var) ~on_change:(Lwd.set var)
|
|
*)
|
|
(* let render (img : Notty.I.t) w h : Wall.Image.t =
|
|
let module WI = Wall.Image in
|
|
let open Operation in
|
|
let simple_text ~x ~y s a : Wall.image =
|
|
let font = get_font a in
|
|
let fm = Text.Font.font_metrics font in
|
|
let font_height = fm.ascent -. fm.descent +. fm.line_gap in
|
|
(* let _, (_, redbox) = path_box Color.red bextent s in*)
|
|
WI.paint (Wall.Paint.color a.fg)
|
|
Text.(simple_text font ~valign:`TOP ~halign:`LEFT ~x ~y s)
|
|
in
|
|
let a' = ref attr_default in
|
|
let rec line (x, y) (op : Operation.t) : Wall.Image.t =
|
|
match op with
|
|
| End -> Image.empty
|
|
| Skip (n, End) -> Image.empty
|
|
| Text (a, x, End) -> erase cap buf ; text_op cap buf a x
|
|
| Skip (n, ops) ->
|
|
WI.stack
|
|
(simple_text !a' (String.make n ' '))
|
|
(line (x, y) 0)
|
|
| Text (a, x, ops) ->
|
|
a' := a ;
|
|
WI.stack (simple_text a x) (line (x, y) ops) in
|
|
let rec lines = function
|
|
| [] -> ()
|
|
| [ln] -> line cap buf ln ; cap.sgr Attr.empty buf
|
|
| ln :: lns ->
|
|
line cap buf ln ; cap.newline buf ; lines cap buf lns
|
|
in
|
|
simple_text
|
|
Operation.of_image (0 0) (w h) img |> lines*)
|
|
|
|
let scroll_area ?(offset = (0, 0)) ?(scroll_step = 1) 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, [] | `ASCII 'v', [`Ctrl] ->
|
|
scroll 0 (-scroll_step * 8)
|
|
| `Page `Down, [] | `ASCII 'v', [`Meta] ->
|
|
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 menu (items : 'a Lwd_table.t) : ui Lwd.t =
|
|
Lwd_table.map_reduce
|
|
(fun row r -> Ui.keyboard_area)
|
|
Ui.pack_y items*)
|
|
|
|
let panel wm () =
|
|
let events, push_event = Lwt_stream.create () in
|
|
let size = ref (200, 200) in
|
|
let check_size ?(scale = 10.) {box; _} =
|
|
let newsize =
|
|
( int_of_float (Box2.w box /. scale)
|
|
, int_of_float (Box2.h box /. scale) ) in
|
|
if newsize <> !size then size := newsize ;
|
|
push_event (Some (`Resize !size)) in
|
|
let pane = ref Display.pane_empty in
|
|
let images = Nottui_lwt.render ~size:!size events wm in
|
|
Lwt.return
|
|
{ act=
|
|
(fun _panel ev ->
|
|
List.iter push_event (convert_events ev) ;
|
|
Lwt_stream.last_new images
|
|
>>= fun img ->
|
|
(pane :=
|
|
fun s ->
|
|
check_size s ;
|
|
draw_pp 20.0
|
|
(fun pp ->
|
|
(Notty.Render.pp Notty.Cap.dumb pp) img ;
|
|
F.flush pp () )
|
|
s ) ;
|
|
Lwt.return !pane )
|
|
; subpanels= []
|
|
; tag= "binding-state" }
|
|
end
|
|
end
|
|
|
|
module Toplevel = struct
|
|
type t =
|
|
{mutable eval: Topinf.evalenv; res: Format.symbolic_output_buffer}
|
|
|
|
let init () =
|
|
let sob = Format.make_symbolic_output_buffer () in
|
|
Topinf.ppf := Format.formatter_of_symbolic_output_buffer sob ;
|
|
{eval= !Topinf.eval; res= sob}
|
|
|
|
let eval t str =
|
|
let ppf = Format.formatter_of_symbolic_output_buffer t.res in
|
|
Topinf.ppf := ppf ;
|
|
ignore (Format.flush_symbolic_output_buffer t.res) ;
|
|
try
|
|
t.eval ppf (str ^ ";;") ;
|
|
(*HACK to prevent getting stuck in parser*)
|
|
let b = Buffer.create 69 in
|
|
Panel.format_symbolic_output_buffer
|
|
(Format.formatter_of_buffer b)
|
|
t.res
|
|
with e ->
|
|
F.pf ppf "Exception in pane_top//eval@." ;
|
|
Location.report_exception ppf e ;
|
|
F.epr "Exception in pane_top//eval@."
|
|
|
|
let result_sob t = t.res
|
|
end
|
|
|
|
module Store = struct
|
|
module Istore = Irmin_unix.Git.FS.KV (Irmin.Contents.String)
|
|
|
|
(* storeview shows items of the selected level *)
|
|
|
|
type storeview =
|
|
{ store: Istore.t
|
|
; mutable view: Istore.key
|
|
; mutable selection: Istore.key
|
|
; mutable editmode: bool
|
|
; sob: Format.symbolic_output_buffer }
|
|
|
|
let make_storeview ?(path = []) storepath branch =
|
|
Istore.Repo.v (Irmin_git.config storepath)
|
|
>>= fun repo ->
|
|
Istore.of_branch repo branch
|
|
>>= fun store ->
|
|
let view = Istore.Key.v path in
|
|
Istore.list store view
|
|
>>= fun viewlist ->
|
|
Lwt.return
|
|
{ store
|
|
; view
|
|
; selection= Istore.Key.v [fst (List.hd viewlist)]
|
|
; editmode= false
|
|
; sob= Format.make_symbolic_output_buffer () }
|
|
|
|
let directives (top : Toplevel.t) sv =
|
|
let dir_use_key key_lid =
|
|
(* TODO: currently causes a segfault :( *)
|
|
let key_obj =
|
|
try
|
|
match
|
|
Env.find_value_by_name key_lid !Topinf.toplevel_env
|
|
with
|
|
| path, _desc ->
|
|
Topinf.eval_value_path !Topinf.toplevel_env path
|
|
| exception Not_found ->
|
|
F.epr "Unbound value %a.@." Printtyp.longident key_lid ;
|
|
raise Exit
|
|
with Exit -> Obj.repr ["nofile"] in
|
|
let key = Obj.obj key_obj in
|
|
let contents =
|
|
Lwt_main.run
|
|
( Istore.kind sv.store key
|
|
>>= function
|
|
| Some a -> (
|
|
match a with
|
|
| `Contents -> Istore.get sv.store key
|
|
| `Node ->
|
|
Lwt.return "\"use_key on Node not implemented yet\"" )
|
|
| None -> Lwt.return "Invalid Selection..." ) in
|
|
Toplevel.eval top contents in
|
|
Topinf.add_directive "use_key" (Directive_ident dir_use_key)
|
|
{ section= "Console Store"
|
|
; doc=
|
|
"Read, compile and execute source phrases from the given \
|
|
store key." }
|
|
|
|
let navigate sv action =
|
|
let rec findi value = function
|
|
| [] -> 0
|
|
| a :: b -> (if a = value then -1 else findi value b) + 1 in
|
|
fun () ->
|
|
Istore.get_tree sv.store sv.view
|
|
>>= fun top ->
|
|
match Istore.Key.rdecons sv.selection with
|
|
| Some (ppath, step) ->
|
|
Istore.Tree.list top ppath
|
|
>>= fun neighbors ->
|
|
let steplist = fst (List.split neighbors) in
|
|
let stepi = findi step steplist in
|
|
Istore.Tree.list (snd (List.nth neighbors stepi)) []
|
|
>>= fun subtreelist ->
|
|
Lwt.return
|
|
( match action with
|
|
| `Next ->
|
|
let stepi = findi step steplist in
|
|
if List.length steplist - 1 > stepi then
|
|
sv.selection <-
|
|
Istore.Key.rcons ppath
|
|
(List.nth steplist (stepi + 1))
|
|
| `Prev ->
|
|
if stepi > 0 then
|
|
sv.selection <-
|
|
Istore.Key.rcons ppath
|
|
(List.nth steplist (stepi - 1))
|
|
| `Sub ->
|
|
if List.length subtreelist > 0 then
|
|
sv.selection <-
|
|
sv.selection @ [fst (List.hd subtreelist)]
|
|
| `Sup ->
|
|
if List.length ppath > 0 then sv.selection <- ppath )
|
|
| None -> Lwt.return_unit
|
|
|
|
let editor ?(branch = "current") storepath : Panel.t Lwt.t =
|
|
make_storeview storepath branch
|
|
>>= fun sv ->
|
|
let top = Toplevel.init () in
|
|
let modalstate = Panel.Modal.make () in
|
|
let te = Panel.Textedit.make "" () in
|
|
let save store path content =
|
|
Lwt.async (fun () ->
|
|
Istore.set_exn store
|
|
~info:(Irmin_unix.info "editor-save")
|
|
path content ) in
|
|
let editbinds =
|
|
let open Input.Bind in
|
|
add
|
|
[([Ctrl], Char 'c')]
|
|
[ Custom
|
|
(fun () ->
|
|
sv.editmode <- not sv.editmode ;
|
|
save sv.store
|
|
(sv.view @ sv.selection)
|
|
(Panel.Textedit.contents te) ) ]
|
|
@@ add
|
|
[([Ctrl], Char 's')]
|
|
[ Custom
|
|
(fun () ->
|
|
save sv.store
|
|
(sv.view @ sv.selection)
|
|
(Panel.Textedit.contents te) ) ]
|
|
@@ add
|
|
[([Ctrl], Char 'x'); ([], Char 'x')]
|
|
[ Custom
|
|
(fun () ->
|
|
Toplevel.eval top (Panel.Textedit.contents te) ) ]
|
|
(Panel.Textedit.bindings te) in
|
|
te.keybind.bindings <- editbinds ;
|
|
let is_node path =
|
|
Istore.get_tree sv.store sv.view
|
|
>>= fun t ->
|
|
Istore.Tree.kind t path
|
|
>>= function
|
|
| Some `Node -> Lwt.return_true | _ -> Lwt.return_false in
|
|
let update_storeview () =
|
|
ignore (Format.flush_symbolic_output_buffer sv.sob) ;
|
|
let pp = Format.formatter_of_symbolic_output_buffer sv.sob in
|
|
let rec draw_levels ?(indent = 0) (sel : Istore.key)
|
|
(tree : Istore.tree) : unit Lwt.t =
|
|
Istore.Tree.list tree []
|
|
>>= Lwt_list.iteri_s (fun _i (step, node) ->
|
|
Format.pp_open_box pp indent ;
|
|
if sel = [step] then (
|
|
Format.pp_open_stag pp
|
|
(Panel.Cursor (Wall.Color.v 0.99 0.99 0.125 0.3)) ;
|
|
F.pf pp "@," ;
|
|
Format.pp_close_stag pp () ) ;
|
|
Istore.Tree.kind node []
|
|
>>= fun k ->
|
|
( match k with
|
|
| Some `Contents ->
|
|
F.pf pp "- %s@." step ; Lwt.return_unit
|
|
| Some `Node ->
|
|
F.pf pp "> %s@." step ;
|
|
let subsel =
|
|
match Istore.Key.decons sel with
|
|
| Some (_tstep, subkey) -> subkey
|
|
| None -> [] in
|
|
Format.pp_open_vbox pp 0 ;
|
|
draw_levels ~indent:(indent + 1) subsel node
|
|
>>= fun () ->
|
|
Format.pp_close_box pp () ;
|
|
Lwt.return_unit
|
|
| None -> F.pf pp "ERROR: None" ; Lwt.return_unit )
|
|
>>= fun () ->
|
|
Format.pp_close_box pp () ;
|
|
Lwt.return_unit ) in
|
|
Istore.get_tree sv.store sv.view >>= draw_levels sv.selection
|
|
in
|
|
let update_textedit () =
|
|
Panel.Textedit.clear te ;
|
|
Istore.get_tree sv.store sv.view
|
|
>>= fun t ->
|
|
Istore.Tree.kind t sv.selection
|
|
>>= function
|
|
| Some `Contents ->
|
|
Istore.Tree.get t sv.selection
|
|
>>= fun content ->
|
|
Panel.Textedit.insert te content ;
|
|
Lwt.return_unit
|
|
| Some `Node ->
|
|
Panel.Textedit.insert te "Node..." ;
|
|
Lwt.return_unit
|
|
| None -> Lwt.return_unit in
|
|
let navbinds =
|
|
let open Input.Bind in
|
|
let new_contents name content =
|
|
Lwt.async (fun () ->
|
|
let s =
|
|
match Istore.Key.rdecons sv.selection with
|
|
| Some (t, _) -> t
|
|
| None -> Istore.Key.empty in
|
|
Istore.get_tree sv.store (sv.view @ s)
|
|
>>= fun tree ->
|
|
Istore.Tree.add tree name content
|
|
>>= fun newtree ->
|
|
Istore.set_tree_exn
|
|
~info:(Irmin_unix.info "new Contents")
|
|
sv.store sv.view newtree ) in
|
|
add [([], Char 'n')] [CustomLwt (navigate sv `Next)]
|
|
@@ add [([], Char 'p')] [CustomLwt (navigate sv `Prev)]
|
|
@@ add [([], Char 'w')] [CustomLwt (navigate sv `Prev)]
|
|
@@ add [([], Char 's')] [CustomLwt (navigate sv `Next)]
|
|
@@ add [([], Char 'd')] [CustomLwt (navigate sv `Sub)]
|
|
@@ add [([], Char 'a')] [CustomLwt (navigate sv `Sup)]
|
|
@@ add
|
|
[([], Char 'e')] (* enter edit mode *)
|
|
[ Custom
|
|
(fun () ->
|
|
Lwt.async (fun () ->
|
|
is_node sv.selection
|
|
>>= fun nb ->
|
|
if not nb then sv.editmode <- not sv.editmode ;
|
|
Lwt.return_unit ) ) ]
|
|
@@ add
|
|
[([], Char 'f')] (* find: enter path in modal *)
|
|
[Custom (fun () -> ())]
|
|
@@ add
|
|
[([], Char 'c')] (* contents: create new contents node *)
|
|
[ Custom
|
|
(fun () ->
|
|
Panel.Modal.start ~prompt:"Contents name > "
|
|
modalstate "" (fun name ->
|
|
new_contents (Istore.Key.v [name]) "" ) ) ]
|
|
@@ add
|
|
[([], Char 't')] (* tree: create new subtree *)
|
|
[ Custom
|
|
(fun () ->
|
|
Panel.Modal.start ~prompt:"Node name > " modalstate
|
|
"" (fun nodename ->
|
|
Panel.Modal.start
|
|
~prompt:"Initial Contents name > " modalstate
|
|
"" (fun contentsname ->
|
|
new_contents
|
|
(Istore.Key.v [nodename; contentsname])
|
|
"" ) ) ) ]
|
|
@@ add
|
|
[([], Char 'r')] (* remove contents/node *)
|
|
[ CustomLwt
|
|
(fun () ->
|
|
let selection = sv.selection in
|
|
navigate sv `Next ()
|
|
>>= fun () ->
|
|
Istore.get_tree sv.store sv.view
|
|
>>= fun tree ->
|
|
Istore.Tree.remove tree selection
|
|
>>= fun newtree ->
|
|
Istore.set_tree_exn
|
|
~info:(Irmin_unix.info "remove Contents/Node")
|
|
sv.store sv.view newtree ) ]
|
|
@@ add
|
|
[([], Char 'x')] (* execute contents/node *)
|
|
[ Custom
|
|
(fun () ->
|
|
Toplevel.eval top (Panel.Textedit.contents te) ) ]
|
|
empty in
|
|
let bindstate = Input.Bind.init navbinds in
|
|
Lwt.return
|
|
Panel.
|
|
{ act=
|
|
(fun panel events ->
|
|
( if
|
|
(not sv.editmode)
|
|
&& not (Panel.Modal.is_active modalstate)
|
|
then
|
|
Input.Bind.process bindstate events
|
|
>>= fun () ->
|
|
Lwt.join [update_storeview (); update_textedit ()]
|
|
else Lwt.return_unit )
|
|
>>= fun () ->
|
|
Panel.vbox panel.subpanels
|
|
>>= fun p -> p.act panel events )
|
|
; subpanels=
|
|
[ Panel.filter_events
|
|
(fun ev ->
|
|
if Panel.Modal.is_active modalstate then ev else []
|
|
)
|
|
(Panel.Modal.panel modalstate)
|
|
; Panel.hbox
|
|
[ Panel.prettyprint (fun pp ->
|
|
Panel.format_symbolic_output_buffer pp sv.sob )
|
|
; Panel.vbox
|
|
[ Panel.filter_events
|
|
(fun ev -> if sv.editmode then ev else [])
|
|
(Panel.Textedit.panel te)
|
|
; Panel.prettyprint (fun pp ->
|
|
Format.pp_open_hovbox pp 0 ;
|
|
Panel.format_symbolic_output_buffer pp
|
|
(Toplevel.result_sob top) ;
|
|
Format.pp_close_box pp () ;
|
|
F.flush pp () ) ] ]
|
|
; Panel.Textedit.bindingstate bindstate
|
|
; Panel.prettyprint (fun pp ->
|
|
Format.fprintf pp "sv.editmode = %b @." sv.editmode )
|
|
]
|
|
; tag= "store-editor" }
|
|
end
|
|
|
|
let std_actor (root_panel : Panel.t Lwt.t) =
|
|
Panel.actor
|
|
(Panel.obox
|
|
[ Panel.draw (fun (s : Display.state) ->
|
|
(s, Display.fill_box (Display.gray 0.125) s.box) )
|
|
; root_panel ] )
|
|
|
|
let root_actor = ref (std_actor (Store.editor "../rootstore"))
|
|
|
|
let start () =
|
|
(* root_actor :=
|
|
std_actor Panel.Nottui.(panel (simple_edit "hello edit") ()) ;*)
|
|
Display.(
|
|
run (make_frame ~title:"hi" ~w:1440 ~h:900 ()) root_actor ())
|
|
|
|
(* 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. *)
|