2264 lines
76 KiB
OCaml
2264 lines
76 KiB
OCaml
(*
|
|
|
|
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 Lwt.Infix
|
|
module F = Fmt
|
|
module Istore = Irmin_unix.Git.FS.KV (Irmin.Contents.String)
|
|
|
|
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 ]
|
|
|
|
(** Type of key code. *)
|
|
type code =
|
|
[`Uchar of Uchar.t (** A unicode character. *) | special]
|
|
|
|
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)
|
|
| CustomLwt of (unit -> unit Lwt.t)
|
|
| 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 =
|
|
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 ->
|
|
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"
|
|
|
|
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 Tsdl
|
|
open Key
|
|
open Gg
|
|
|
|
type mouse = V2.t
|
|
|
|
type t =
|
|
[ `Key of [`Press | `Release | `Repeat] * keystate
|
|
| `Mouse of mouse
|
|
| `Quit
|
|
| `Fullscreen of bool
|
|
| `Unknown of string ]
|
|
|
|
type events = t list
|
|
|
|
let to_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 sdlkey_map = Hashtbl.create 1024
|
|
|
|
let () =
|
|
let aa (x : int) (y : Key.code) = Hashtbl.add sdlkey_map x y in
|
|
let open Sdl.K in
|
|
aa return `Enter ;
|
|
aa escape `Escape ;
|
|
aa backspace `Backspace ;
|
|
aa tab `Tab ;
|
|
aa f1 (`Function 1) ;
|
|
aa f2 (`Function 2) ;
|
|
aa f3 (`Function 3) ;
|
|
aa f4 (`Function 4) ;
|
|
aa f5 (`Function 5) ;
|
|
aa f6 (`Function 6) ;
|
|
aa f7 (`Function 7) ;
|
|
aa f8 (`Function 8) ;
|
|
aa f9 (`Function 9) ;
|
|
aa f10 (`Function 10) ;
|
|
aa f11 (`Function 11) ;
|
|
aa f12 (`Function 12) ;
|
|
aa insert `Insert ;
|
|
aa delete `Delete ;
|
|
aa home `Home ;
|
|
aa kend `End ;
|
|
aa pageup (`Page `Up) ;
|
|
aa pagedown (`Page `Down) ;
|
|
aa right (`Arrow `Right) ;
|
|
aa left (`Arrow `Left) ;
|
|
aa down (`Arrow `Down) ;
|
|
aa up (`Arrow `Up)
|
|
|
|
let key_of_sdlkey ev =
|
|
let (kc : Sdl.keycode) =
|
|
Sdl.Event.get ev Sdl.Event.keyboard_keycode
|
|
land lnot Sdl.K.scancode_mask in
|
|
match (Hashtbl.find_opt sdlkey_map kc, Uchar.is_valid kc) with
|
|
| Some s, _ -> Some s
|
|
| None, true -> Some (`Uchar (Uchar.of_int kc))
|
|
| None, false -> None
|
|
|
|
let event_of_sdlevent ev : t option =
|
|
match Sdl.Event.enum (Sdl.Event.get ev Sdl.Event.typ) with
|
|
| (`Key_down | `Key_up) as d -> (
|
|
match key_of_sdlkey ev with
|
|
| None -> None
|
|
| Some code ->
|
|
let km = Sdl.Event.get ev Sdl.Event.keyboard_keymod in
|
|
Some
|
|
(`Key
|
|
( ( match d with
|
|
| _
|
|
when Sdl.Event.get ev Sdl.Event.keyboard_repeat > 1
|
|
->
|
|
`Repeat
|
|
| `Key_up -> `Release
|
|
| _ -> `Press )
|
|
, { code
|
|
; 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 } ) ) )
|
|
| `Mouse_motion ->
|
|
let x, y = snd (Tsdl.Sdl.get_mouse_state ()) in
|
|
Some (`Mouse (V2.v (float x) (float y)))
|
|
| `Quit -> Some `Quit
|
|
(* Unhandled events *)
|
|
| `Text_editing -> Some (`Unknown "`Text_editing")
|
|
| `Text_input -> Some (`Unknown "`Text_input")
|
|
| `App_did_enter_background ->
|
|
Some (`Unknown "`App_did_enter_background")
|
|
| `App_did_enter_foreground ->
|
|
Some (`Unknown "`App_did_enter_foreground ")
|
|
| `App_low_memory -> Some (`Unknown "`App_low_memory ")
|
|
| `App_terminating -> Some (`Unknown "`App_terminating ")
|
|
| `App_will_enter_background ->
|
|
Some (`Unknown "`App_will_enter_background ")
|
|
| `App_will_enter_foreground ->
|
|
Some (`Unknown "`App_will_enter_foreground ")
|
|
| `Clipboard_update -> Some (`Unknown "`Clipboard_update ")
|
|
| `Controller_axis_motion ->
|
|
Some (`Unknown "`Controller_axis_motion ")
|
|
| `Controller_button_down ->
|
|
Some (`Unknown "`Controller_button_down ")
|
|
| `Controller_button_up -> Some (`Unknown "`Controller_button_up ")
|
|
| `Controller_device_added ->
|
|
Some (`Unknown "`Controller_device_added ")
|
|
| `Controller_device_remapped ->
|
|
Some (`Unknown "`Controller_device_remapped ")
|
|
| `Controller_device_removed ->
|
|
Some (`Unknown "`Controller_device_removed ")
|
|
| `Dollar_gesture -> Some (`Unknown "`Dollar_gesture ")
|
|
| `Dollar_record -> Some (`Unknown "`Dollar_record ")
|
|
| `Drop_file -> Some (`Unknown "`Drop_file ")
|
|
| `Finger_down -> Some (`Unknown "`Finger_down")
|
|
| `Finger_motion -> Some (`Unknown "`Finger_motion ")
|
|
| `Finger_up -> Some (`Unknown "`Finger_up ")
|
|
| `Joy_axis_motion -> Some (`Unknown "`Joy_axis_motion ")
|
|
| `Joy_ball_motion -> Some (`Unknown "`Joy_ball_motion ")
|
|
| `Joy_button_down -> Some (`Unknown "`Joy_button_down ")
|
|
| `Joy_button_up -> Some (`Unknown "`Joy_button_up ")
|
|
| `Joy_device_added -> Some (`Unknown "`Joy_device_added ")
|
|
| `Joy_device_removed -> Some (`Unknown "`Joy_device_removed ")
|
|
| `Joy_hat_motion -> Some (`Unknown "`Joy_hat_motion ")
|
|
| `Mouse_button_down -> Some (`Unknown "`Mouse_button_down ")
|
|
| `Mouse_button_up -> Some (`Unknown "`Mouse_button_up")
|
|
| `Mouse_wheel -> Some (`Unknown "`Mouse_wheel ")
|
|
| `Multi_gesture -> Some (`Unknown "`Multi_gesture")
|
|
| `Sys_wm_event -> Some (`Unknown "`Sys_wm_event ")
|
|
| `Unknown e -> Some (`Unknown (Format.sprintf "`Unknown %d" e))
|
|
| `User_event -> Some (`Unknown "`User_event ")
|
|
| `Display_event -> Some (`Unknown "`Display_event ")
|
|
| `Sensor_update -> Some (`Unknown "`Sensor_update ")
|
|
| `Window_event -> Some (`Unknown "`Window_event ")
|
|
|
|
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
|
|
|
|
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
|
|
match Event.event_of_sdlevent ev with
|
|
| Some e -> get_events () @ [e]
|
|
| None -> get_events ()
|
|
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
|
|
|
|
module FontCache = Map.Make (String)
|
|
|
|
let font_cache = ref FontCache.empty
|
|
|
|
let load_font name =
|
|
match FontCache.find_opt name !font_cache with
|
|
| Some font -> font
|
|
| None -> (
|
|
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_cache := FontCache.add name font !font_cache ;
|
|
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 =
|
|
Wall_text.Font.make ~size:(Box2.h b) (Lazy.force font_sans)
|
|
in
|
|
( Box2.v (Box2.o b)
|
|
(P2.v (Wall_text.Font.text_width f text) (Box2.h b))
|
|
, I.paint
|
|
(Paint.color (gray ~a:0.5 1.0))
|
|
Wall_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 = Wall_text.Font.font_metrics f in
|
|
let font_height = fm.ascent -. fm.descent +. fm.line_gap in
|
|
let tm = Wall_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))
|
|
Wall_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 }
|
|
|
|
type panel = t
|
|
|
|
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 =
|
|
Wall_text.Font.make ~size:height (Lazy.force font_sans) in
|
|
let fm = Wall_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 = Wall_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 /. Wall_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: Key.Bind.action Key.Bind.state }
|
|
|
|
let bindings te =
|
|
let open Key.Bind in
|
|
add [([], U (`Arrow `Left))] [Zed Prev_char]
|
|
@@ add [([], U (`Arrow `Right))] [Zed Next_char]
|
|
@@ add [([], U (`Arrow `Up))] [Zed Prev_line]
|
|
@@ add [([], U (`Arrow `Down))] [Zed Next_line]
|
|
@@ add [([], U `Home)] [Zed Goto_bol]
|
|
@@ add [([], U `End)] [Zed Goto_eol]
|
|
@@ add [([], U `Insert)] [Zed Switch_erase_mode]
|
|
@@ add [([], U `Delete)] [Zed Delete_next_char]
|
|
@@ add [([], U `Enter)] [Zed Newline]
|
|
@@ add [([Ctrl], C ' ')] [Zed Set_mark]
|
|
@@ add [([Ctrl], C 'a')] [Zed Goto_bol]
|
|
@@ add [([Ctrl], C 'e')] [Zed Goto_eol]
|
|
@@ add [([Ctrl], C 'd')] [Zed Delete_next_char]
|
|
@@ add [([Ctrl], C 'h')] [Zed Delete_prev_char]
|
|
@@ add [([Ctrl], C 'k')] [Zed Kill_next_line]
|
|
@@ add [([Ctrl], C 'u')] [Zed Kill_prev_line]
|
|
@@ add [([Ctrl], C 'n')] [Zed Next_line]
|
|
@@ add [([Ctrl], C 'p')] [Zed Prev_line]
|
|
@@ add [([Ctrl], C 'w')] [Zed Kill]
|
|
@@ add [([Ctrl], C 'y')] [Zed Yank]
|
|
@@ add [([], U `Backspace)] [Zed Delete_prev_char]
|
|
@@ add [([Meta], C 'w')] [Zed Copy]
|
|
@@ add [([Meta], C 'c')] [Zed Capitalize_word]
|
|
@@ add [([Meta], C 'l')] [Zed Lowercase_word]
|
|
@@ add [([Meta], C 'u')] [Zed Uppercase_word]
|
|
@@ add [([Meta], C 'b')] [Zed Prev_word]
|
|
@@ add [([Meta], C 'f')] [Zed Next_word]
|
|
@@ add [([Meta], U (`Arrow `Right))] [Zed Next_word]
|
|
@@ add [([Meta], U (`Arrow `Left))] [Zed Prev_word]
|
|
@@ add [([Ctrl], U (`Arrow `Right))] [Zed Next_word]
|
|
@@ add [([Ctrl], U (`Arrow `Left))] [Zed Prev_word]
|
|
@@ add [([Meta], U `Backspace)] [Zed Kill_prev_word]
|
|
@@ add [([Meta], U `Delete)] [Zed Kill_prev_word]
|
|
@@ add [([Ctrl], U `Delete)] [Zed Kill_next_word]
|
|
@@ add [([Meta], C 'd')] [Zed Kill_next_word]
|
|
@@ add [([Ctrl], C '/')] [Zed Undo]
|
|
@@ add [([Ctrl], C 'x'); ([], C 'u')] [Zed Undo]
|
|
@@ add
|
|
[([Ctrl], C '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], C '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= Key.Bind.(init 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 (`Press, (k : Key.keystate)) -> (
|
|
let open Key.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
|
|
| Custom f -> Lwt.return (f ())
|
|
| CustomLwt f -> f ()
|
|
| Zed za ->
|
|
Lwt.return
|
|
(Zed_edit.get_action za te.zed) )
|
|
a
|
|
| Continue _ | Rejected -> Lwt.return_unit )
|
|
| _ -> 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 : Key.Bind.action Key.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 ->
|
|
Key.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
|
|
^ Key.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 Key.Bind in
|
|
add
|
|
[([], U `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 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 get a =
|
|
Wall_text.Font.make ~size:(size a)
|
|
(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" ) )
|
|
|
|
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.fmax 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 ) }
|
|
end
|
|
|
|
type t = {fg: Wall.color; bg: Wall.color; font: Font.t}
|
|
type attr = t
|
|
|
|
let empty = {fg= Color.void; bg= Color.void; font= Font.empty}
|
|
let light = {empty with fg= Color.gray 0.2}
|
|
let dark = {empty with fg= Color.gray 0.8}
|
|
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 merge a b =
|
|
{ fg= Wall.Color.blend a.fg b.fg
|
|
; bg= Wall.Color.blend a.bg b.bg
|
|
; font= Font.merge a.font b.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 }
|
|
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
|
|
open Wall
|
|
|
|
type t =
|
|
[ `Atom of atom
|
|
| `Attr of attr * node
|
|
| `Join of dir * node * node ]
|
|
|
|
and node = {mutable parent: node option; mutable t: t; n: int}
|
|
and cursor = {root: node; mutable sel: node}
|
|
|
|
and atom =
|
|
[ `Image of image
|
|
| `Uchar of Uchar.t
|
|
| `Boundary of [`Word | `Line | `Sentance]
|
|
| `Hint of [`Line | `Other]
|
|
| `Empty ]
|
|
|
|
and attr =
|
|
[ `Style of style
|
|
| `Pad of Pad.t
|
|
| `Shift of dim
|
|
| `Handler of handler ]
|
|
|
|
and dir = [`X | `Y | `Z]
|
|
and dim = Size2.t
|
|
and image = Wall.image * dim
|
|
and style = Style.t
|
|
and handler = node -> Event.t -> Event.t option Lwt.t
|
|
|
|
let set_parent_on_children n : node =
|
|
( match n.t with
|
|
| `Atom _ -> ()
|
|
| `Attr (_, a) -> a.parent <- Some n
|
|
| `Join (_, a, b) ->
|
|
a.parent <- Some n ;
|
|
b.parent <- Some n ) ;
|
|
n
|
|
|
|
let node_count = ref 0
|
|
|
|
let node_n () =
|
|
node_count := !node_count + 1 ;
|
|
!node_count - 1
|
|
|
|
let node (t : t) =
|
|
set_parent_on_children {parent= None; t; n= node_n ()}
|
|
|
|
let empty_image = (Image.empty, V2.zero)
|
|
let empty_node = node (`Atom `Empty)
|
|
let style (s : Style.t) (n : node) = node (`Attr (`Style s, n))
|
|
|
|
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_attr (a : attr) (n : node) : node =
|
|
let p = n.parent in
|
|
let n' = node (`Attr (a, n)) in
|
|
n'.parent <- p ;
|
|
( match p with
|
|
| Some p ->
|
|
p.t <-
|
|
( match p.t with
|
|
| `Attr (a, _) -> `Attr (a, n')
|
|
| `Join (d, a, b) when n == a -> `Join (d, n', b)
|
|
| `Join (d, a, b) when n == b -> `Join (d, a, n')
|
|
| _ -> assert false )
|
|
| None -> () ) ;
|
|
n'
|
|
|
|
let remove_attr (n : node) : node =
|
|
match n.t with
|
|
| `Attr (_, n') ->
|
|
( match n.parent with
|
|
| Some p ->
|
|
p.t <-
|
|
( match p.t with
|
|
| `Attr (a, _) -> `Attr (a, n')
|
|
| `Join (d, a, b) when n == a -> `Join (d, n', b)
|
|
| `Join (d, a, b) when n == b -> `Join (d, a, n')
|
|
| _ -> assert false ) ;
|
|
ignore (set_parent_on_children p)
|
|
| None -> () ) ;
|
|
n'
|
|
| _ -> assert false
|
|
|
|
let sub (n : node) : node =
|
|
match n.t with
|
|
| `Atom _ -> n
|
|
| `Attr (_, n) -> n
|
|
| `Join (_, a, _) -> a
|
|
|
|
let join_ d (a : node) (b : node) =
|
|
set_parent_on_children
|
|
{parent= a.parent; t= `Join (d, a, b); n= node_n ()}
|
|
|
|
let join_x = join_ `X
|
|
let join_y = join_ `Y
|
|
let join_z = join_ `Z
|
|
let pack_x : node Lwd_utils.monoid = (empty_node, join_x)
|
|
let pack_y : node Lwd_utils.monoid = (empty_node, join_y)
|
|
let pack_z : node Lwd_utils.monoid = (empty_node, 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 append_x = append_ `X
|
|
let append_y = append_ `Y
|
|
let append_z = append_ `Z
|
|
|
|
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_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 "
|
|
++
|
|
match b with
|
|
| `Word -> any "`Word"
|
|
| `Line -> any "`Line"
|
|
| `Sentance -> any "`Sentance" )
|
|
| `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 ..." ) )
|
|
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"
|
|
(record [field "n" (fun v -> v.n) int; any "..."])
|
|
v)
|
|
|
|
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_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)
|
|
(option (fun ppf v -> pf ppf "%a" int v.n)) ] ) )
|
|
v
|
|
|
|
and pp_node ppf v = _pp_node pp_node_n ppf v
|
|
and pp_dump_node ppf v = _pp_node pp_dump_node ppf v
|
|
|
|
let pp_t = _pp_t pp_node_n
|
|
|
|
(* there's no difference between a node element and a node list what, tho an element is kinda like a node.t,
|
|
so i guess we'll use that to kinda emulate append (vs. concat which is what join is)
|
|
ugh maybe using types to build this double-linked binary-tree data structure is not a good idea.
|
|
I'm STONED, so i'm not making sense, but i'm gonna carry on anyway and see what happens.
|
|
So i think what is really happening is that i'm defining the `list` for this node type that allows `append`.
|
|
The main problem with this thought is that you can't do anything but append with the datastructure.
|
|
*)
|
|
|
|
module Text = struct
|
|
let rec of_string (str : string) : node =
|
|
let uudec = Uutf.decoder (`String str) in
|
|
let rec dec (lx : node -> node) : 'a * (node -> node) =
|
|
match Uutf.decode uudec with
|
|
| `Malformed b ->
|
|
dec (append_x lx (of_string (String.escaped b)))
|
|
| (`Await | `Uchar _ | `End) as x -> (x, lx) in
|
|
let uuline = Uuseg.create `Line_break in
|
|
let rec char (x, (l : node -> node)) =
|
|
match Uuseg.add uuline x with
|
|
| `End as x -> (l, x)
|
|
| `Await -> char (dec l)
|
|
| `Boundary as x when Uuseg.mandatory uuline -> (l, x)
|
|
| `Boundary ->
|
|
char (`Await, append_x l (node (`Atom (`Hint `Line))))
|
|
| `Uchar c ->
|
|
char (`Await, append_x l (node (`Atom (`Uchar c))))
|
|
in
|
|
let rec new_line la : node -> node =
|
|
match char (`Await, la) with
|
|
| l, `Boundary ->
|
|
new_line
|
|
(append_y la (l (node (`Atom (`Boundary `Line)))))
|
|
| l, `End -> l in
|
|
(new_line (fun n -> n)) empty_node
|
|
|
|
(* let segment ?(boundary = `Word) ?(label = `Word) (node : node) :
|
|
node =
|
|
let uuseg = Uuseg.create boundary in
|
|
traverse_regions
|
|
~node:(fun node -> node)
|
|
~region:(fun ~parent (r, c) ~child ->
|
|
match child.child with
|
|
| `Atom (`Uchar uc) ->
|
|
let rec seg ((t : node Trope.t), (c : Region.cursor))
|
|
e' =
|
|
match Uuseg.add uuseg e' with
|
|
| `Boundary ->
|
|
seg
|
|
( Trope.put_right t c
|
|
{parent; child= `Atom (`Boundary label)}
|
|
, Trope.cursor_after c )
|
|
`Await
|
|
| `End | `Await -> (t, c)
|
|
| `Uchar ch ->
|
|
seg
|
|
( Trope.put_right t c
|
|
{parent; child= `Atom (`Uchar ch)}
|
|
, c )
|
|
`Await in
|
|
let r', c' = seg (r.t, c) (`Uchar uc) in
|
|
({r with t= r'}, c')
|
|
| _ -> (r, c) )
|
|
node
|
|
|
|
let words node : node =
|
|
segment ~boundary:`Word ~label:`Word node
|
|
|
|
let sentances node : node =
|
|
segment ~boundary:`Sentence ~label:`Sentance node
|
|
|
|
let text str : node = insert_string str |> sentances |> words *)
|
|
end
|
|
|
|
let text = Text.of_string
|
|
|
|
module Draw = struct
|
|
type d = [`X | `Y | `Z]
|
|
|
|
let cursor ((i, v) : image) =
|
|
( I.stack
|
|
(I.paint (Paint.color Color.red)
|
|
( I.stroke_path (Outline.make ())
|
|
@@ fun t ->
|
|
P.rect t ~x:0. ~y:0. ~w:(V2.x v) ~h:(V2.y v) ) )
|
|
i
|
|
, v )
|
|
|
|
let vcat d a b =
|
|
match d with
|
|
| `X -> V2.v (V2.x a +. V2.x b) (Float.fmax (V2.y a) (V2.y b))
|
|
| `Y -> V2.v (Float.fmax (V2.x a) (V2.x b)) (V2.y a +. V2.y b)
|
|
| `Z ->
|
|
V2.v
|
|
(Float.fmax (V2.x a) (V2.x b))
|
|
(Float.fmax (V2.y a) (V2.y b))
|
|
|
|
let pad (p : Pad.t) (img, sv) =
|
|
( I.transform Transform.(translate ~x:p.l ~y:p.t identity) img
|
|
, V2.v (p.l +. V2.x sv +. p.r) (p.t +. V2.y sv +. p.b) )
|
|
|
|
let shift v (img, sv) =
|
|
( I.transform
|
|
Transform.(
|
|
translate ~x:(Size2.w v) ~y:(Size2.h v) identity)
|
|
img
|
|
, sv )
|
|
|
|
let uchar (style : Style.t) (uc : Uchar.t) : image =
|
|
let open Wall_text in
|
|
let f = Style.Font.get style.font in
|
|
let b = 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 str = Bytes.to_string (Buffer.to_bytes b) in
|
|
let m = Wall_text.Font.text_measure f str in
|
|
let v = Gg.Size2.v m.width (f.size +. f.line_height) in
|
|
( I.stack
|
|
(I.paint
|
|
(Wall.Paint.color style.fg)
|
|
(simple_text f ~valign:`TOP ~halign:`LEFT ~x:0. ~y:0.
|
|
str ) )
|
|
(I.paint
|
|
(Wall.Paint.color style.bg)
|
|
( I.fill_path
|
|
@@ fun t ->
|
|
P.rect t ~x:0. ~y:0. ~w:(Size2.w v) ~h:(Size2.h v) ) )
|
|
, v )
|
|
|
|
let cat d (ai, av) (bi, bv) =
|
|
( I.stack ai
|
|
(I.transform
|
|
Transform.(
|
|
match d with
|
|
| `X -> translate ~x:(Size2.w av) ~y:0. identity
|
|
| `Y -> translate ~x:0. ~y:(Size2.h av) identity
|
|
| `Z -> translate ~x:0. ~y:0. identity)
|
|
bi )
|
|
, vcat d av bv )
|
|
|
|
let rec atom ?(style = Style.empty) : atom -> image = function
|
|
| `Image i -> i
|
|
| `Uchar uc -> uchar style uc
|
|
| `Boundary _ -> empty_image
|
|
| `Hint _ -> empty_image
|
|
| `Empty -> empty_image
|
|
|
|
and attr ?(style = Style.empty) (attr, node) : image =
|
|
match attr with
|
|
| `Style s -> pane ~style:(Style.merge s style) node
|
|
| `Pad p -> pad p (pane ~style node)
|
|
| `Shift s -> shift s (pane ~style node)
|
|
| _ -> pane ~style node
|
|
|
|
and join ?(style = Style.empty) (d, a, b) : image =
|
|
cat d (pane ~style a) (pane ~style b)
|
|
|
|
and pane ?(style = Style.empty) (node : node) : image =
|
|
match node.t with
|
|
| `Atom a -> atom ~style a
|
|
| `Attr a -> attr ~style a
|
|
| `Join a -> join ~style a
|
|
end
|
|
|
|
module Action = struct
|
|
type segment_type =
|
|
[`Char | `Word | `Phrase | `Line | `Page | `Region]
|
|
|
|
and segment =
|
|
[ `Beginning of segment_type
|
|
| `Forward of segment_type
|
|
| `Backward of segment_type
|
|
| `End of segment_type ]
|
|
|
|
and t =
|
|
[ `Move of segment
|
|
| `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_type ppf v =
|
|
any
|
|
( match v with
|
|
| `Char -> "`Char"
|
|
| `Word -> "`Word"
|
|
| `Phrase -> "`Phrase"
|
|
| `Line -> "`Line"
|
|
| `Page -> "`Page"
|
|
| `Region -> "`Region" )
|
|
ppf ()
|
|
|
|
let pp_segment ppf v =
|
|
( match v with
|
|
| `Beginning s -> any "`Beginning " ++ const pp_segment_type s
|
|
| `Forward s -> any "`Forward " ++ const pp_segment_type s
|
|
| `Backward s -> any "`Backward " ++ const pp_segment_type s
|
|
| `End s -> any "`End " ++ const pp_segment_type s )
|
|
ppf ()
|
|
|
|
let pp_t ppf v =
|
|
( match v with
|
|
| `Move s -> any "`Move " ++ const pp_segment s
|
|
| `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 tree_next (n : node) =
|
|
let rec next_right n' =
|
|
match n'.parent with
|
|
| None -> None
|
|
| Some ({t= `Attr _; _} as p) -> next_right p
|
|
| Some {t= `Join (_, a, b); _} when n' == a -> Some b
|
|
| Some ({t= `Join (_, _, b); _} as p) when n' == b ->
|
|
next_right p
|
|
| Some {t= `Join _; _} -> assert false
|
|
| Some {t= `Atom _; _} -> assert false in
|
|
match n.t with
|
|
| `Atom _ -> next_right n
|
|
| `Attr (_, n') -> Some n'
|
|
| `Join (_, a, _) -> Some a
|
|
|
|
let tree_prev (n : node) =
|
|
match n.parent with
|
|
| None -> None
|
|
| Some ({t; _} as p) -> (
|
|
match t with
|
|
| `Atom _ -> assert false (* shouldn't happen *)
|
|
| `Attr _ -> Some p
|
|
| `Join (_, a, _) when a == n -> Some p
|
|
| `Join (_, a, b) when b == n -> Some a
|
|
| `Join _ -> assert false (* shouldn't happen *) )
|
|
|
|
let rec search_forward (n : node) (f : node -> 'a option) :
|
|
'a option =
|
|
match f n with
|
|
| None -> (
|
|
match tree_next n with
|
|
| Some n' -> search_forward n' f
|
|
| None -> None )
|
|
| x -> x
|
|
|
|
let rec search_backward (n : node) (f : node -> 'a option) :
|
|
'a option =
|
|
match tree_prev n with
|
|
| None -> None
|
|
| Some p -> (
|
|
match f p with
|
|
| None -> search_backward p f
|
|
| Some x -> Some x )
|
|
|
|
let perform_action (a : Action.t) (c : cursor) : node option =
|
|
let r =
|
|
match a with
|
|
| `Move (`Beginning `Char) -> None
|
|
| `Move (`Beginning `Word) ->
|
|
search_backward c.sel (fun n ->
|
|
match n.t with
|
|
| `Atom (`Boundary `Word) -> Some n
|
|
| _ -> None )
|
|
| `Move (`Forward `Char) ->
|
|
search_forward c.sel (fun n ->
|
|
match n.t with
|
|
| _ when n == c.sel -> None
|
|
(* TODO proper detection of root | _ when n == c.root -> Some n *)
|
|
| `Atom (`Uchar _) -> Some n
|
|
| _ -> None )
|
|
| `Move (`Backward `Char) ->
|
|
search_backward c.sel (fun n ->
|
|
match n.t with
|
|
(* TODO proper detection of root | _ when n == c.root -> Some np *)
|
|
| `Atom (`Uchar _) -> Some n
|
|
| _ -> None )
|
|
| `Move _ -> None
|
|
| `Yank _s -> None
|
|
| `Kill _s -> None
|
|
| `Descend -> Some (sub c.sel)
|
|
| `Ascend -> c.sel.parent
|
|
| `Custom _s -> None in
|
|
match r with
|
|
| Some n ->
|
|
c.sel <- n ;
|
|
Some n
|
|
| None -> 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 [([Ctrl], C 'b')] [`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 [([Ctrl], C 'p')] [`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 [([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 'e')] [`Descend]
|
|
|
|
let join_search_forward n =
|
|
search_forward n (fun v ->
|
|
match v.t with `Join _ -> Some v | _ -> None )
|
|
|
|
let cursor_attr = `Style Style.(bg Color.(blend red green))
|
|
|
|
let textedit_handler ?(bindings = textedit_bindings) (n : node) =
|
|
let bind = Key.Bind.init bindings in
|
|
let c =
|
|
{ root= n
|
|
; sel=
|
|
insert_attr
|
|
(`Style Style.(bg Color.(blend red green)))
|
|
( match join_search_forward n with
|
|
| Some n -> n
|
|
| None -> n ) } in
|
|
Format.pp_set_max_boxes F.stderr 99999 ;
|
|
Format.(
|
|
F.epr
|
|
"@[<hv>F.stderr margin: %d, max_indent: %d, max_boxes: %d \
|
|
@]@."
|
|
(pp_get_margin F.stderr ())
|
|
(pp_get_max_indent F.stderr ())
|
|
(pp_get_max_boxes F.stderr ())) ;
|
|
node
|
|
(`Attr
|
|
( `Handler
|
|
(fun (_ : node) (e : Event.t) : Event.t option Lwt.t ->
|
|
match Key.Bind.resolve_events bind [e] with
|
|
| x :: _ ->
|
|
c.sel <- remove_attr c.sel ;
|
|
( match perform_action x c with
|
|
| Some _ ->
|
|
F.epr
|
|
"textedit_handler perform_action @[%a@] \
|
|
success@."
|
|
Action.pp_t x
|
|
| None ->
|
|
F.epr
|
|
"textedit_handler perform_action @[%a@] \
|
|
FAILURE@."
|
|
Action.pp_t x ) ;
|
|
c.sel <- insert_attr cursor_attr c.sel ;
|
|
Lwt.return_none
|
|
| [] -> Lwt.return_some e )
|
|
, n ) )
|
|
|
|
let handler_of_node (n : node) : handler option =
|
|
search_forward n (fun n ->
|
|
match n.t with `Attr (`Handler f, _) -> Some f | _ -> None )
|
|
|
|
let handle_event (n : node) (ev : Event.t) : event_status Lwt.t =
|
|
match handler_of_node n with
|
|
| Some f -> (
|
|
f n ev
|
|
>>= function
|
|
| Some ev -> Lwt.return (`Event ev)
|
|
| None -> Lwt.return `Handled )
|
|
| None -> Lwt.return (`Event ev)
|
|
|
|
let panel (t : node Lwd.t) : (Event.events -> image Lwt.t) Lwt.t =
|
|
let rq = Lwd.make_release_queue () in
|
|
let root = Lwd.observe t in
|
|
Lwt.return (fun ev ->
|
|
let r = Lwd.sample rq root in
|
|
(* F.epr "Draw.pane: %a@." pp_ui r ; *)
|
|
Lwt_list.iter_s
|
|
(fun e ->
|
|
handle_event r e
|
|
>>= fun h ->
|
|
( match h with
|
|
| `Handled -> F.epr "Handled %s@." (Event.to_string e)
|
|
| `Event _e ->
|
|
(* F.epr "Unhandled event: %s@."
|
|
(Event.to_string _e)*)
|
|
() ) ;
|
|
Lwt.return_unit )
|
|
ev
|
|
>|= fun () -> Draw.pane r )
|
|
|
|
let test =
|
|
panel
|
|
(Lwd.pure
|
|
(textedit_handler
|
|
(style Style.dark
|
|
(* (join_y
|
|
(join_y
|
|
(Text.of_string
|
|
"-- welcome to my land of idiocy ---" )
|
|
(join_x
|
|
(Text.of_string "hello bitch")
|
|
(Text.of_string "!\n sup daddy") ) )*)
|
|
(Text.of_string "123") ) ) )
|
|
(* ) *)
|
|
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
|
|
(* 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 Key.Bind in
|
|
add
|
|
[([Ctrl], C 'c')]
|
|
[ Custom
|
|
(fun () ->
|
|
sv.editmode <- not sv.editmode ;
|
|
save sv.store
|
|
(sv.view @ sv.selection)
|
|
(Panel.Textedit.contents te) ) ]
|
|
@@ add
|
|
[([Ctrl], C 's')]
|
|
[ Custom
|
|
(fun () ->
|
|
save sv.store
|
|
(sv.view @ sv.selection)
|
|
(Panel.Textedit.contents te) ) ]
|
|
@@ add
|
|
[([Ctrl], C 'x'); ([], C '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 Key.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 [([], C 'n')] [CustomLwt (navigate sv `Next)]
|
|
@@ add [([], C 'p')] [CustomLwt (navigate sv `Prev)]
|
|
@@ add [([], C 'w')] [CustomLwt (navigate sv `Prev)]
|
|
@@ add [([], C 's')] [CustomLwt (navigate sv `Next)]
|
|
@@ add [([], C 'd')] [CustomLwt (navigate sv `Sub)]
|
|
@@ add [([], C 'a')] [CustomLwt (navigate sv `Sup)]
|
|
@@ add
|
|
[([], C '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
|
|
[([], C 'f')] (* find: enter path in modal *)
|
|
[Custom (fun () -> ())]
|
|
@@ add
|
|
[([], C 'c')] (* contents: create new contents node *)
|
|
[ Custom
|
|
(fun () ->
|
|
Panel.Modal.start ~prompt:"Contents name > "
|
|
modalstate "" (fun name ->
|
|
new_contents (Istore.Key.v [name]) "" ) ) ]
|
|
@@ add
|
|
[([], C '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
|
|
[([], C '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
|
|
[([], C 'x')] (* execute contents/node *)
|
|
[ Custom
|
|
(fun () ->
|
|
Toplevel.eval top (Panel.Textedit.contents te) ) ]
|
|
empty in
|
|
let bindstate = Key.Bind.init navbinds in
|
|
Lwt.return
|
|
Panel.
|
|
{ act=
|
|
(fun panel events ->
|
|
( if
|
|
(not sv.editmode)
|
|
&& not (Panel.Modal.is_active modalstate)
|
|
then
|
|
Key.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 image_pane (f : (Event.events -> Panel.Ui.image Lwt.t) Lwt.t) :
|
|
Panel.t Lwt.t =
|
|
f (* do the initialization (lol what?) *)
|
|
>>= fun f ->
|
|
Lwt.return
|
|
Panel.
|
|
{ act=
|
|
(fun _ events ->
|
|
f events
|
|
>>= fun i ->
|
|
Lwt.return (fun s ->
|
|
(s, (Gg.Box2.of_pts Gg.V2.zero (snd i), fst i)) ) )
|
|
; subpanels= []
|
|
; tag= "irc" }
|
|
|
|
let root_actor =
|
|
ref
|
|
(std_actor
|
|
(image_pane Panel.Ui.test) (*Store.editor "../rootstore"*) )
|
|
|
|
let start () =
|
|
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. *)
|