1457 lines
50 KiB
OCaml
1457 lines
50 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 ()
|
|
| _ -> 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 "
|
|
| `Window_event -> `Unknown "`Window_event "
|
|
| `Display_event -> `Unknown "`Display_event "
|
|
| `Sensor_update -> `Unknown "`Sensor_update " 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 () ->
|
|
let width, height = Sdl.gl_get_drawable_size frame.sdl_win in
|
|
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 get_events () =
|
|
(* create and fill event list *)
|
|
let convert_event = Event.event_of_sdlevent in
|
|
let ev = Sdl.Event.create () in
|
|
let events : Event.t list ref = ref [] in
|
|
if Sdl.wait_event_timeout (Some ev) 20 then (
|
|
events := !events @ [convert_event ev] ;
|
|
while Sdl.wait_event_timeout (Some ev) 1 do
|
|
events := !events @ [convert_event ev]
|
|
done ) ;
|
|
events
|
|
|
|
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 *)
|
|
!actor !events
|
|
>>= fun p ->
|
|
F.epr "pane generated@." ;
|
|
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 (
|
|
ignore (draw_pane frame frame.last_pane) ;
|
|
Lwt.return_unit )
|
|
|
|
let run frame actor () =
|
|
let frame = get_result frame in
|
|
Sdl.show_window frame.sdl_win ;
|
|
let rec loop () =
|
|
display_frame frame actor
|
|
>>= fun () ->
|
|
Lwt.pause () (* seems required for the irc connection to work *)
|
|
>>= 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_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 -> (t * Display.pane) Lwt.t
|
|
; mutable subpanels: t Lwt.t list
|
|
; mutable tag: string }
|
|
|
|
let blank =
|
|
{ act=
|
|
(fun panel _events -> Lwt.return (panel, Display.pane_empty))
|
|
; subpanels= []
|
|
; tag= "blank pane" }
|
|
|
|
let draw (pane : Display.pane) =
|
|
Lwt.return
|
|
{ act= (fun panel _events -> Lwt.return (panel, pane))
|
|
; subpanels= []
|
|
; tag= "draw-pane" }
|
|
|
|
let actor (panel : t) : Event.events -> Display.pane Lwt.t =
|
|
fun events ->
|
|
panel.act panel events >>= fun (_panel, 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))}
|
|
|
|
(* draws subsequent items below *)
|
|
let vbox subpanels =
|
|
Lwt.return
|
|
{ act=
|
|
(fun panel events ->
|
|
Lwt_list.map_p
|
|
(fun s ->
|
|
s
|
|
>>= fun subpanel ->
|
|
subpanel.act subpanel events
|
|
>>= fun (_panel, pane) -> Lwt.return pane )
|
|
panel.subpanels
|
|
>>= fun pl -> Lwt.return (panel, 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 ->
|
|
Lwt_list.map_p
|
|
(fun s ->
|
|
s
|
|
>>= fun subpanel ->
|
|
subpanel.act subpanel events
|
|
>>= fun (_panel, pane) -> Lwt.return pane )
|
|
panel.subpanels
|
|
>>= fun pl -> Lwt.return (panel, 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 ->
|
|
Lwt_list.map_p
|
|
(fun subpanel ->
|
|
subpanel
|
|
>>= fun subpanel ->
|
|
subpanel.act subpanel events
|
|
>>= fun (_panel, pane) -> Lwt.return pane )
|
|
panel.subpanels
|
|
>>= fun pl -> Lwt.return (panel, 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_buffer (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 out_funs_of_sob sob =
|
|
Format.
|
|
{ out_string=
|
|
(fun s p n ->
|
|
add_symbolic_output_item sob
|
|
(Output_string (String.sub s p n)) )
|
|
; out_flush=
|
|
(fun () -> add_symbolic_output_item sob Output_flush)
|
|
; out_indent=
|
|
(fun n -> add_symbolic_output_item sob (Output_indent n))
|
|
; out_newline=
|
|
(fun () -> add_symbolic_output_item sob Output_newline)
|
|
; out_spaces=
|
|
(fun n -> add_symbolic_output_item sob (Output_spaces n)) }
|
|
|
|
let prettyprint ?(height = !g_text_height) ?(tag = "pretty-print")
|
|
fpp =
|
|
Lwt.return
|
|
{ act=
|
|
(fun panel _events -> Lwt.return (panel, draw_pp height fpp))
|
|
; subpanels= []
|
|
; tag }
|
|
|
|
module Textedit = struct
|
|
let bindings =
|
|
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]
|
|
@@ empty
|
|
|
|
type t =
|
|
{ mutable zed: unit Zed_edit.context
|
|
; mutable keybind: Input.Bind.state }
|
|
|
|
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)
|
|
; keybind= Input.Bind.init keybinds } in
|
|
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 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
|
|
Format.pp_open_hvbox pp 0 ;
|
|
F.text pp before_cursor ;
|
|
Format.pp_open_stag pp
|
|
(Cursor (Wall.Color.v 0.99 0.99 0.125 0.3)) ;
|
|
F.pf pp "" ;
|
|
Format.pp_close_stag pp () ;
|
|
F.text pp after_cursor ;
|
|
F.pf pp "@." ;
|
|
Format.pp_close_box pp () ) in
|
|
Lwt.return (panel, 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
|
|
( panel
|
|
, 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 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 (panel, 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
|
|
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)
|
|
(Format.get_symbolic_output_buffer 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 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
|
|
(Format.get_symbolic_output_buffer 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
|
|
(Format.get_symbolic_output_buffer
|
|
(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 () =
|
|
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. *)
|