console/boot
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Files
50073f19e1a8226f8869d723835d9ce492c773b9
boot/human.ml

2328 lines
80 KiB
OCaml
Raw Blame History

(*
a computation console
- irmin store provides a tree of data objects
- the tree can be navigated in the default view
- the selected object can be edited <enter> or executed as an ocaml top level phrase <C-enter>
- each execution stores any edited modifications and the command to execute that phrase in the current irmin store context as a commit message
- while editing a data object <ctrl-enter> wille search for the previous and next `;;` or BOF/EOF and execute the enclosed text and the commit message includes the character offsets of the executed text.
- executions can modify the window system creating new windows and redirecting input focus. They define their own input handling however C-g,C-g,C-g will restore the window system to the default??
but how do we integrate this with the ocaml environment and name spaces??
some options:
- always wrap execution units from data objects in some sort of local namespace so opens are not global?
- dig into the toplevel environment and manipulate it, this will also help with things like completion and context help
*)
open Lwt.Infix
module F = Fmt
module Input = struct
open CamomileLibrary
(** Type of key code. *)
type code =
| UChar of UChar.t (** A unicode character. *)
| Enter
| Escape
| Tab
| Up
| Down
| Left
| Right
| F1
| F2
| F3
| F4
| F5
| F6
| F7
| F8
| F9
| F10
| F11
| F12
| Next_page
| Prev_page
| Home
| End
| Insert
| Delete
| Backspace
| Unknown
| None
type keystate =
{ctrl: bool; meta: bool; shift: bool; super: bool; code: code}
type mods = Ctrl | Meta | Super | Shift
type key = Char of char | Code of code
module Key = struct
type t = keystate
let compare = compare
end
module Bind = struct
(* parts stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *)
module S = Zed_input.Make (Key)
type action =
| Custom of (unit -> unit)
| CustomLwt of (unit -> unit Lwt.t)
| Zed of Zed_edit.action
type t = action list S.t
type resolver = action list S.resolver
type result = action list S.result
type state =
{ mutable bindings: t
; mutable state: result
; mutable last_keyseq: keystate list
; mutable last_actions: action list }
let keystate_of_mods ks m =
List.fold_left
(fun ks m ->
match m with
| Meta -> {ks with meta= true}
| Ctrl -> {ks with ctrl= true}
| Super -> {ks with super= true}
| Shift -> {ks with shift= true} )
ks m
let add events action bindings =
let events =
List.map
(fun (m, k) ->
keystate_of_mods
{ meta= false
; ctrl= false
; super= false
; shift= false
; code=
( match k with
| Char c -> UChar (UChar.of_char c)
| Code c -> c ) }
m )
events in
S.add events action bindings
let default_resolver b = S.resolver [S.pack (fun x -> x) b]
let get_resolver result default =
match result with S.Continue r -> r | _ -> default
let init bindings =
{bindings; state= S.Rejected; last_keyseq= []; last_actions= []}
let resolve = S.resolve
let empty = S.empty
let actions_of_events (state : state) events =
List.flatten
(List.filter_map
(fun e ->
(*F.epr "action_of_events: %s@." (to_string e) ;*)
match e with
| `Key_down (k : keystate) -> (
( match state.state with
| Continue _ -> ()
| _ -> state.last_keyseq <- [] ) ;
state.state <-
resolve k
(get_resolver state.state
(default_resolver state.bindings) ) ;
state.last_keyseq <- k :: state.last_keyseq ;
match state.state with
| Accepted a ->
state.last_actions <- a ;
Some a
| Rejected ->
state.last_actions <- [] ;
None
| _ -> None )
| _ -> None )
events )
let process bindstate events =
Lwt_list.iter_s
(function
| Custom f -> Lwt.return (f ())
| CustomLwt f -> f ()
| Zed _ -> Lwt.return_unit )
(actions_of_events bindstate events)
end
(* stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *)
let string_of_code = function
| UChar ch -> Printf.sprintf "Char 0x%02x" (UChar.code ch)
| Enter -> "Enter"
| Escape -> "Escape"
| Tab -> "Tab"
| Up -> "Up"
| Down -> "Down"
| Left -> "Left"
| Right -> "Right"
| F1 -> "F1"
| F2 -> "F2"
| F3 -> "F3"
| F4 -> "F4"
| F5 -> "F5"
| F6 -> "F6"
| F7 -> "F7"
| F8 -> "F8"
| F9 -> "F9"
| F10 -> "F10"
| F11 -> "F11"
| F12 -> "F12"
| Next_page -> "Next_page"
| Prev_page -> "Prev_page"
| Home -> "Home"
| End -> "End"
| Insert -> "Insert"
| Delete -> "Delete"
| Backspace -> "Backspace"
| Unknown -> "Unknown"
| None -> "None"
let to_string key =
Printf.sprintf
"{ control = %B; meta = %B; shift = %B; super = %B; code = %s }"
key.ctrl key.meta key.shift key.super
(string_of_code key.code)
let to_string_compact key =
let buffer = Buffer.create 32 in
if key.ctrl then Buffer.add_string buffer "Ctrl-" ;
if key.meta then Buffer.add_string buffer "Meta-" ;
if key.shift then Buffer.add_string buffer "Shift-" ;
if key.super then Buffer.add_string buffer "Super-" ;
( match key.code with
| UChar ch ->
let code = UChar.code ch in
if code <= 255 then
match Char.chr code with
| ( 'a' .. 'z'
| 'A' .. 'Z'
| '0' .. '9'
| '_' | '(' | ')' | '[' | ']' | '{' | '}' | '#' | '~'
| '&' | '$' | '*' | '%' | '!' | '?' | ',' | ';' | ':'
| '/' | '\\' | '.' | '@' | '=' | '+' | '-' ) as ch ->
Buffer.add_char buffer ch
| ' ' -> Buffer.add_string buffer "space"
| _ -> Printf.bprintf buffer "U+%02x" code
else if code <= 0xffff then
Printf.bprintf buffer "U+%04x" code
else Printf.bprintf buffer "U+%06x" code
| Next_page -> Buffer.add_string buffer "next"
| Prev_page -> Buffer.add_string buffer "prev"
| code ->
Buffer.add_string buffer
(String.lowercase_ascii (string_of_code code)) ) ;
Buffer.contents buffer
end
module Event = struct
open Tsdl
open CamomileLibrary
open Input
type mouse = int * int
type t =
[ `Key_down of Input.keystate
| `Key_up of Input.keystate
| `Text_editing of string
| `Text_input of string
| `Mouse of mouse
| `Quit
| `Fullscreen of bool
| `Unknown of string
| `None ]
type events = t list
let string_of_event = function
| `Key_down _ -> "`Key_down"
| `Key_up _ -> "`Key_up"
| `Text_editing _ -> "`Text_editing"
| `Text_input _ -> "`Text_input"
| `Mouse _ -> "`Mouse"
| `Quit -> "`Quit"
| `Fullscreen _ -> "`Fullscreen"
| `Unknown _ -> "`Unknown"
| `None -> "`None"
let to_string ev =
let p =
match ev with
| `Key_down k | `Key_up k -> Input.to_string k
| `Text_editing s | `Text_input s -> s
| `Mouse _ -> ""
| `Fullscreen b -> Format.sprintf "%b" b
| `Unknown s -> s
| `Quit | `None -> "" in
string_of_event ev ^ " " ^ p
let event_of_sdlevent ev =
let key_of_sdlkey ev =
let (kc : Sdl.keycode) =
Sdl.Event.get ev Sdl.Event.keyboard_keycode
land lnot Sdl.K.scancode_mask in
let open Sdl.K in
let (c : Input.code) =
match (kc : Sdl.keycode) with
(* HACK WHENENENENENENENENEHWEHWEHNWEWHWEHWEN FUCK X WHEN X whatS>!!>!> *)
| x when x = return -> Enter
| x when x = escape -> Escape
| x when x = backspace -> Backspace
| x when x = tab -> Tab
| x when x = f1 -> F1
| x when x = f2 -> F2
| x when x = f3 -> F3
| x when x = f4 -> F4
| x when x = f5 -> F5
| x when x = f6 -> F6
| x when x = f7 -> F7
| x when x = f8 -> F8
| x when x = f9 -> F9
| x when x = f10 -> F10
| x when x = f11 -> F11
| x when x = f12 -> F12
| x when x = insert -> Insert
| x when x = delete -> Delete
| x when x = home -> Home
| x when x = kend -> End
| x when x = pageup -> Prev_page
| x when x = pagedown -> Next_page
| x when x = right -> Right
| x when x = left -> Left
| x when x = down -> Down
| x when x = up -> Up
| k -> (
match UChar.char_of (UChar.of_int k) with
| 'a' .. 'z'
|'A' .. 'Z'
|'0' .. '9'
|'_' | '(' | ')' | '[' | ']' | '{' | '}' | '#' | '~'
|'&' | '$' | '*' | '%' | '!' | '?' | ',' | ';' | ':'
|'/' | '\\' | '.' | '@' | '=' | '+' | '-' | ' ' | '"'
|'\'' | '>' | '<' | '^' | '`' | '|' ->
UChar (UChar.of_int k)
| _ -> None ) in
let km = Sdl.Event.get ev Sdl.Event.keyboard_keymod in
{ code= c
; ctrl= km land Sdl.Kmod.ctrl > 0
; meta= km land Sdl.Kmod.alt > 0
; super= km land Sdl.Kmod.gui > 0
; shift= km land Sdl.Kmod.shift > 0 } in
let repeat = Sdl.Event.get ev Sdl.Event.keyboard_repeat in
let r =
match Sdl.Event.enum (Sdl.Event.get ev Sdl.Event.typ) with
| `Text_editing ->
`Unknown
(Format.sprintf "`Text_editing %s"
(Sdl.Event.get ev Sdl.Event.text_editing_text) )
| `Text_input ->
`Text_input (Sdl.Event.get ev Sdl.Event.text_input_text)
| `Key_down ->
if repeat < 1 then `Key_down (key_of_sdlkey ev) else `None
| `Key_up ->
if repeat < 1 then `Key_up (key_of_sdlkey ev) else `None
| `Mouse_motion ->
let _, mouse_xy = Tsdl.Sdl.get_mouse_state () in
`Mouse mouse_xy
| `Quit -> `Quit
(* Unhandled events *)
| `App_did_enter_background ->
`Unknown "`App_did_enter_background"
| `App_did_enter_foreground ->
`Unknown "`App_did_enter_foreground "
| `App_low_memory -> `Unknown "`App_low_memory "
| `App_terminating -> `Unknown "`App_terminating "
| `App_will_enter_background ->
`Unknown "`App_will_enter_background "
| `App_will_enter_foreground ->
`Unknown "`App_will_enter_foreground "
| `Clipboard_update -> `Unknown "`Clipboard_update "
| `Controller_axis_motion -> `Unknown "`Controller_axis_motion "
| `Controller_button_down -> `Unknown "`Controller_button_down "
| `Controller_button_up -> `Unknown "`Controller_button_up "
| `Controller_device_added ->
`Unknown "`Controller_device_added "
| `Controller_device_remapped ->
`Unknown "`Controller_device_remapped "
| `Controller_device_removed ->
`Unknown "`Controller_device_removed "
| `Dollar_gesture -> `Unknown "`Dollar_gesture "
| `Dollar_record -> `Unknown "`Dollar_record "
| `Drop_file -> `Unknown "`Drop_file "
| `Finger_down -> `Unknown "`Finger_down"
| `Finger_motion -> `Unknown "`Finger_motion "
| `Finger_up -> `Unknown "`Finger_up "
| `Joy_axis_motion -> `Unknown "`Joy_axis_motion "
| `Joy_ball_motion -> `Unknown "`Joy_ball_motion "
| `Joy_button_down -> `Unknown "`Joy_button_down "
| `Joy_button_up -> `Unknown "`Joy_button_up "
| `Joy_device_added -> `Unknown "`Joy_device_added "
| `Joy_device_removed -> `Unknown "`Joy_device_removed "
| `Joy_hat_motion -> `Unknown "`Joy_hat_motion "
| `Mouse_button_down -> `Unknown "`Mouse_button_down "
| `Mouse_button_up -> `Unknown "`Mouse_button_up"
| `Mouse_wheel -> `Unknown "`Mouse_wheel "
| `Multi_gesture -> `Unknown "`Multi_gesture"
| `Sys_wm_event -> `Unknown "`Sys_wm_event "
| `Unknown e -> `Unknown (Format.sprintf "`Unknown %d " e)
| `User_event -> `Unknown "`User_event "
| `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 rec get_events () : Event.t list =
(* create and fill event list *)
let ev = Sdl.Event.create () in
if Sdl.poll_event (Some ev) then
get_events () @ [Event.event_of_sdlevent ev]
else []
let 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 ->
frame.last_pane <- p ;
(* call draw_pane because we should redraw now that we have updated *)
ignore (draw_pane frame frame.last_pane) ;
Lwt.return_unit )
else Lwt.return_unit
let run frame actor () =
let frame = get_result frame in
Sdl.show_window frame.sdl_win ;
let rec loop () =
Lwt.pause () (* seems required for the irc connection to work *)
>>= fun () ->
Lwt_unix.sleep 0.030
>>= fun () ->
display_frame frame actor
>>= fun () ->
if not frame.quit then loop () else Lwt.return_unit in
Lwt_main.run (loop ()) ;
print_endline "quit" ;
Sdl.hide_window frame.sdl_win ;
Sdl.gl_delete_context frame.gl ;
Sdl.destroy_window frame.sdl_win ;
Sdl.quit () ;
()
let gray ?(a = 1.0) v = Color.v v v v a
let load_font name =
let ic = open_in_bin name in
let dim = in_channel_length ic in
let fd = Unix.descr_of_in_channel ic in
let buffer =
Unix.map_file fd Bigarray.int8_unsigned Bigarray.c_layout false
[|dim|]
|> Bigarray.array1_of_genarray in
let offset = List.hd (Stb_truetype.enum buffer) in
match Stb_truetype.init buffer offset with
| None -> assert false
| Some font -> font
let font_icons = lazy (load_font "fonts/entypo.ttf")
let font_sans = lazy (load_font "fonts/Roboto-Regular.ttf")
let font_sans_bold = lazy (load_font "fonts/Roboto-Bold.ttf")
let font_sans_light = lazy (load_font "fonts/Roboto-Light.ttf")
let font_emoji = lazy (load_font "fonts/NotoEmoji-Regular.ttf")
let str_of_box b =
Printf.sprintf "(ox:%0.1f oy:%0.1f ex%0.1f ey%0.1f)" (Box2.ox b)
(Box2.oy b) (Box2.maxx b) (Box2.maxy b)
let draw_label text b =
let f = Text.Font.make ~size:(Box2.h b) (Lazy.force font_sans) in
( Box2.v (Box2.o b) (P2.v (Text.Font.text_width f text) (Box2.h b))
, I.paint
(Paint.color (gray ~a:0.5 1.0))
Text.(
simple_text f ~valign:`BASELINE ~halign:`LEFT ~x:(Box2.ox b)
~y:(Box2.oy b +. (Box2.h b *. 0.75))
text) )
let fill_box c b =
( b
, I.paint (Paint.color c)
( I.fill_path
@@ fun t ->
P.rect t ~x:(Box2.ox b) ~y:(Box2.oy b) ~w:(Box2.w b)
~h:(Box2.h b) ) )
let draw_filled_box c (s : state) = (s, fill_box c s.box)
let path_box c b (s : state) =
( s
, ( b
, I.paint (Paint.color c)
( I.stroke_path (Outline.make ())
@@ fun t ->
P.rect t ~x:(Box2.ox b) ~y:(Box2.oy b) ~w:(Box2.w b)
~h:(Box2.h b) ) ) )
let path_circle c b (s : state) =
( s
, ( b
, I.paint (Paint.color c)
( I.stroke_path (Outline.make ())
@@ fun t ->
P.circle t ~cx:(Box2.midx b) ~cy:(Box2.midy b)
~r:(Box2.w b /. 2.) ) ) )
(** Display.state.box as supplied to a widget defines the allowed drawing area for the widget.
This way basic widgets will just expand to the full area of a box, while other widgets can have
the express purpose of limiting the size of an object in a larger system of limitations.
Panes return a tuple: (state, (box, image))
state is the updated state, where state.box is always
- the top left corner of the box the pane drew in, and
- the bottom right corner of the state.box that was passed in
box is the area the widget actually drew in (or wants to sort of "use")
image is the Wall.image to compose with other panes and draw to the display
*)
let simple_text f text (s : state) =
let fm = Text.Font.font_metrics f in
let font_height = fm.ascent -. fm.descent +. fm.line_gap in
let tm = Text.Font.text_measure f text in
let br_pt =
P2.v (Box2.ox s.box +. tm.width) (Box2.oy s.box +. font_height)
in
let bextent = Box2.of_pts (Box2.o s.box) br_pt in
(* let _, (_, redbox) = path_box Color.red bextent s in*)
( {s with box= Box2.of_pts (Box2.br_pt bextent) (Box2.max s.box)}
, ( bextent
, (* I.stack redbox *)
I.paint
(Paint.color (gray ~a:0.5 1.0))
Text.(
simple_text f ~valign:`BASELINE ~halign:`LEFT
~x:(Box2.ox s.box)
~y:(Box2.oy s.box +. fm.ascent)
text) ) )
let pane_box next_point_func (subpanes : pane list) (so : state) =
let sr, (br, ir) =
List.fold_left
(fun (sp, (bp, ip)) (pane : pane) ->
(* uses br to hold max extent of boxes *)
let sr, (br, ir) = pane sp in
(* draw the pane *)
let _, (_, irb) = path_box Color.blue br sr in
(* draw the box around the pane *)
( { sr with
box= Box2.of_pts (next_point_func br) (Box2.max sp.box)
}
, ( Box2.of_pts (Box2.o bp)
(P2.v
(max (Box2.maxx br) (Box2.maxx bp))
(max (Box2.maxy br) (Box2.maxy bp)) )
, Image.seq [ip; irb; ir] ) ) )
( so
, (Box2.of_pts (Box2.o so.box) (Box2.o so.box), Image.empty)
)
subpanes in
let _, (_, redbox) = path_box Color.red br sr in
(sr, (br, Image.stack redbox ir))
end
module Panel = struct
open Display
open Gg
type t =
{ mutable act: t -> Event.events -> Display.pane Lwt.t
; mutable subpanels: t Lwt.t list
; mutable tag: string }
let blank =
{ act= (fun _panel _events -> Lwt.return Display.pane_empty)
; subpanels= []
; tag= "blank pane" }
let draw (pane : Display.pane) =
Lwt.return
{ act= (fun _panel _events -> Lwt.return pane)
; subpanels= []
; tag= "draw-pane" }
let actor (panel : t) : Event.events -> Display.pane Lwt.t =
fun events ->
panel.act panel events >>= fun pane -> Lwt.return pane
let filter_events ef p =
p
>>= fun p' ->
Lwt.return
{p' with act= (fun panel events -> p'.act panel (ef events))}
let resolve_panels events =
Lwt_list.map_s (fun s ->
s
>>= fun subpanel ->
subpanel.act subpanel events >>= fun pane -> Lwt.return pane )
(* draws subsequent items below *)
let vbox subpanels =
Lwt.return
{ act=
(fun panel events ->
resolve_panels events panel.subpanels
>|= fun pl -> pane_box Box2.tl_pt pl )
(* tl_pt is actually bl_pt in the Wall coordinate system *)
; subpanels
; tag= "vertical-box" }
(* draws subsequent item to the right *)
let hbox subpanels =
Lwt.return
{ act=
(fun panel events ->
resolve_panels events panel.subpanels
>|= fun pl -> pane_box Box2.br_pt pl )
(* br_pt is actually tr_pt in the Wall coordinate system *)
; subpanels
; tag= "horizontal-box" }
(* draws subsequent panels overtop each other *)
let obox (subpanels : t Lwt.t list) =
{ act=
(fun panel events ->
resolve_panels events panel.subpanels
>|= fun pl -> pane_box Box2.o pl )
; subpanels
; tag= "origin-box" }
let g_text_height = ref 25.
type Format.stag += Color_bg of Wall.color
type Format.stag += Color_fg of Wall.color
type Format.stag += Cursor of Wall.color
type Format.stag += None_tag
let draw_pp height fpp (s : state) =
let node, sc, box = (ref I.empty, ref s, ref Box2.zero) in
let push (s, (b, i)) =
node := I.stack !node i ;
sc := s ;
box := b in
let font = Text.Font.make ~size:height (Lazy.force font_sans) in
let fm = Text.Font.font_metrics font in
let font_height = fm.ascent -. fm.descent +. fm.line_gap in
let max_x = ref 0. in
let out_string text o l =
let sp = !sc in
push @@ simple_text font (String.sub text o l) !sc ;
max_x := max !max_x (Box2.maxx !box) ;
sc :=
{ !sc with
box=
Box2.of_pts
(P2.v (Box2.maxx !box) (Box2.oy sp.box))
(Box2.max sp.box) } in
let out_flush () = () in
let out_newline () =
sc :=
{ !sc with
box=
Box2.of_pts
(P2.v (Box2.ox s.box) (Box2.oy !sc.box +. font_height))
(Box2.max s.box) } in
let out_spaces n =
let wpx = Text.Font.text_width font " " in
if Box2.ox !sc.box +. (float n *. wpx) > Box2.maxx !sc.box then
(* WRAP *)
out_newline () ;
let so = !sc in
(* let bsp = Box2.v (Box2.br_pt !box) (P2.v wpx height) in
push @@ pane_hbox (List.init n (fun _ -> path_circle Color.green bsp)) !sc;*)
box := Box2.v (Box2.o so.box) (P2.v (float n *. wpx) height) ;
sc :=
{!sc with box= Box2.of_pts (Box2.br_pt !box) (Box2.max so.box)}
in
let out_indent n =
let p = min (Box2.w !sc.box -. 1.) (height *. 2.0 *. float n) in
sc :=
{ !sc with
box=
Box2.of_pts
(P2.v (Box2.ox !sc.box +. p) (Box2.oy !sc.box))
(Box2.max !sc.box) } in
let out_funs =
Format.
{out_string; out_flush; out_newline; out_spaces; out_indent}
in
let pp = Format.formatter_of_out_functions out_funs in
Format.pp_set_formatter_stag_functions pp
{ mark_open_stag=
(fun s ->
( match s with
| Cursor c ->
push
@@ ( !sc
, fill_box c
(Box2.v (Box2.o !sc.box)
(P2.v (height *. 0.333) height) ) )
| Color_bg c -> push @@ (!sc, fill_box c !box)
| _ -> () ) ;
"" )
; mark_close_stag= (function _ -> () ; "")
; print_open_stag= (fun _ -> (*"<open_stag>"*) ())
; (* TKTKTKTK XXX IT SHOULD BE USING THESE print ONES *)
print_close_stag= (fun _ -> (*"<close_stag>"*) ()) } ;
Format.pp_set_tags pp true ;
let margin =
int_of_float (Box2.w s.box /. Text.Font.text_width font " ")
in
let max_indent = margin - 1 in
Format.pp_safe_set_geometry pp ~max_indent ~margin ;
fpp pp ;
Format.pp_force_newline pp () ;
( !sc
, ( Box2.of_pts (Box2.o s.box) (P2.v !max_x (Box2.maxy !box))
, !node ) )
let format_symbolic_output_items (ppf : Format.formatter) buf =
List.iter
Format.(
function
| Output_flush -> F.pf ppf "@?"
| Output_newline -> F.pf ppf "@."
| Output_string s -> Format.pp_print_string ppf s
| Output_spaces n | Output_indent n ->
Format.pp_print_string ppf (String.make n ' '))
buf
let format_symbolic_output_buffer (ppf : Format.formatter) buf =
format_symbolic_output_items ppf
(Format.get_symbolic_output_buffer buf)
let prettyprint ?(height = !g_text_height) ?(tag = "pretty-print")
fpp =
Lwt.return
{ act= (fun _panel _events -> Lwt.return (draw_pp height fpp))
; subpanels= []
; tag }
module Textedit = struct
type t =
{ mutable zed: unit Zed_edit.context
; mutable view: Zed_cursor.t
; mutable keybind: Input.Bind.state }
let bindings te =
let open Input.Bind in
add [([], Code Left)] [Zed Prev_char]
@@ add [([], Code Right)] [Zed Next_char]
@@ add [([], Code Up)] [Zed Prev_line]
@@ add [([], Code Down)] [Zed Next_line]
@@ add [([], Code Home)] [Zed Goto_bol]
@@ add [([], Code End)] [Zed Goto_eol]
@@ add [([], Code Insert)] [Zed Switch_erase_mode]
@@ add [([], Code Delete)] [Zed Delete_next_char]
@@ add [([], Code Enter)] [Zed Newline]
@@ add [([Ctrl], Char ' ')] [Zed Set_mark]
@@ add [([Ctrl], Char 'a')] [Zed Goto_bol]
@@ add [([Ctrl], Char 'e')] [Zed Goto_eol]
@@ add [([Ctrl], Char 'd')] [Zed Delete_next_char]
@@ add [([Ctrl], Char 'h')] [Zed Delete_prev_char]
@@ add [([Ctrl], Char 'k')] [Zed Kill_next_line]
@@ add [([Ctrl], Char 'u')] [Zed Kill_prev_line]
@@ add [([Ctrl], Char 'n')] [Zed Next_line]
@@ add [([Ctrl], Char 'p')] [Zed Prev_line]
@@ add [([Ctrl], Char 'w')] [Zed Kill]
@@ add [([Ctrl], Char 'y')] [Zed Yank]
@@ add [([], Code Backspace)] [Zed Delete_prev_char]
@@ add [([Meta], Char 'w')] [Zed Copy]
@@ add [([Meta], Char 'c')] [Zed Capitalize_word]
@@ add [([Meta], Char 'l')] [Zed Lowercase_word]
@@ add [([Meta], Char 'u')] [Zed Uppercase_word]
@@ add [([Meta], Char 'b')] [Zed Prev_word]
@@ add [([Meta], Char 'f')] [Zed Next_word]
@@ add [([Meta], Code Right)] [Zed Next_word]
@@ add [([Meta], Code Left)] [Zed Prev_word]
@@ add [([Ctrl], Code Right)] [Zed Next_word]
@@ add [([Ctrl], Code Left)] [Zed Prev_word]
@@ add [([Meta], Code Backspace)] [Zed Kill_prev_word]
@@ add [([Meta], Code Delete)] [Zed Kill_prev_word]
@@ add [([Ctrl], Code Delete)] [Zed Kill_next_word]
@@ add [([Meta], Char 'd')] [Zed Kill_next_word]
@@ add [([Ctrl], Char '/')] [Zed Undo]
@@ add [([Ctrl], Char 'x'); ([], Char 'u')] [Zed Undo]
@@ add
[([Ctrl], Char 'v')]
[ Custom
(fun () ->
let r = Zed_edit.text (Zed_edit.edit te.zed) in
let l = Zed_lines.of_rope r in
let i = Zed_cursor.get_line te.view in
Zed_cursor.goto te.view
(Zed_lines.line_start l i + 10) ) ]
@@ add
[([Meta], Char 'v')]
[ Custom
(fun () ->
let r = Zed_edit.text (Zed_edit.edit te.zed) in
let l = Zed_lines.of_rope r in
let i = Zed_cursor.get_line te.view in
Zed_cursor.goto te.view
(Zed_lines.line_start l i - 10) ) ]
@@ empty
let clear te =
let ze = Zed_edit.create () in
te.zed <- Zed_edit.context ze (Zed_edit.new_cursor ze)
let insert te text =
Zed_edit.insert te.zed
(Zed_rope.of_string (Zed_string.of_utf8 text))
let contents (te : t) =
Zed_string.to_utf8
(Zed_rope.to_string (Zed_edit.text (Zed_edit.edit te.zed)))
let make ?(keybinds = bindings) initialtext () =
let ze = Zed_edit.create () in
let te =
{ zed= Zed_edit.context ze (Zed_edit.new_cursor ze)
; view= Zed_edit.new_cursor ze
; keybind= Input.Bind.init Input.Bind.empty } in
te.keybind.bindings <- keybinds te ;
insert te initialtext ;
te
let panel ?(height = !g_text_height) te =
Lwt.return
{ act=
(fun _panel events ->
(* collect events and update Zed context *)
Lwt_list.iter_s
(function
| `Key_down (k : Input.keystate) -> (
let open Input.Bind in
( match te.keybind.state with
| Accepted _ | Rejected ->
te.keybind.last_keyseq <- [] ;
te.keybind.last_actions <- []
| Continue _ -> () ) ;
te.keybind.state <-
resolve k
(get_resolver te.keybind.state
(default_resolver te.keybind.bindings) ) ;
te.keybind.last_keyseq <-
k :: te.keybind.last_keyseq ;
match te.keybind.state with
| Accepted a ->
te.keybind.last_actions <- a ;
Lwt_list.iter_s
(function
| Input.Bind.Custom f ->
Lwt.return (f ())
| Input.Bind.CustomLwt f -> f ()
| Zed za ->
Lwt.return
(Zed_edit.get_action za te.zed) )
a
| Continue _ | Rejected -> Lwt.return_unit )
| `Key_up _ -> Lwt.return_unit
| `Text_input s ->
Lwt.return
(Zed_edit.insert te.zed
(Zed_rope.of_string (Zed_string.of_utf8 s)) )
| _ -> Lwt.return_unit )
events
>>= fun () ->
let draw_textedit =
draw_pp height (fun pp ->
let _, view =
Zed_rope.break
(Zed_edit.text (Zed_edit.edit te.zed))
(Zed_cursor.get_position te.view) in
Format.pp_open_hvbox pp 0 ;
if
Zed_cursor.get_position te.view
> Zed_cursor.get_position
(Zed_edit.cursor te.zed)
then (
let zrb, zra =
Zed_rope.break
(Zed_edit.text (Zed_edit.edit te.zed))
(Zed_cursor.get_position
(Zed_edit.cursor te.zed) ) in
let before_cursor =
Zed_string.to_utf8 (Zed_rope.to_string zrb)
in
let after_cursor =
Zed_string.to_utf8 (Zed_rope.to_string zra)
in
F.text pp before_cursor ;
Format.pp_open_stag pp
(Cursor (Wall.Color.v 0.99 0.99 0.125 0.3)) ;
F.pf pp "" ;
Format.pp_close_stag pp () ;
F.text pp after_cursor )
else
F.text pp
(Zed_string.to_utf8 (Zed_rope.to_string view)) ;
F.pf pp "@." ;
Format.pp_close_box pp () ) in
Lwt.return draw_textedit )
; subpanels= []
; tag= "textedit" }
(* pane that displays last key binding match state *)
let bindingstate ?(height = !g_text_height) (b : Input.Bind.state)
=
Lwt.return
{ act=
(fun _panel _events ->
Lwt.return
(draw_pp height (fun pp ->
Format.pp_open_hbox pp () ;
F.text pp
(List.fold_left
(fun s x ->
Input.to_string_compact x ^ " " ^ s )
"" b.last_keyseq ) ;
F.text pp "-> " ;
F.text pp
( match b.state with
| Accepted a ->
"Accepted "
^ List.fold_right
(fun x s ->
s
^ Input.Bind.(
match x with
| Zed a ->
Zed_edit.name_of_action a
| CustomLwt _ -> "CustomLwt"
| Custom _ -> "Custom")
^ "; " )
a ""
| Rejected -> "Rejected"
| Continue _ -> "Continue" ) ;
Format.pp_close_box pp () ;
F.flush pp () ) ) )
; subpanels= []
; tag= "binding-state" }
end
module InuitTextedit = struct
(* Most of this module stolen from https://github.com/let-def/inuit and heavily modified:
Copyright (c) 2016 Frédéric Bour
Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies.
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
open Format
type 'a clickable = [> `Clickable | `Clicked] as 'a
type 'a editable = [> `Editable | `Prompt] as 'a
module Patch = struct
type symbols = symbolic_output_item list
type operation =
| Remove of int
| Insert of symbols
| Replace of int * symbols
| Propertize of int
type 'flags t =
{ offset: int (** Starting at [offset]'th unicode sequence *)
; operation: operation
; text_len: int
; flags: 'flags list
(** A list of backend defined [flags]. *) }
let make ~offset flags operation =
{ flags
; offset
; operation
; text_len=
( match operation with
| Insert text | Replace (_, text) -> List.length text
| _ -> 0 ) }
let with_flags flags t =
if t.flags == flags then t else {t with flags}
let removed t =
match t.operation with
| Insert _ | Propertize _ -> 0
| Remove n | Replace (n, _) -> n
let inserted t =
match t.operation with
| Insert _ | Replace _ -> t.text_len
| Propertize _ | Remove _ -> 0
let inserted_text t =
match t.operation with
| Insert txt | Replace (_, txt) -> txt
| Propertize _ | Remove _ -> []
end
type 'flags patch = 'flags Patch.t
type side = [`Local | `Remote]
let cons_some x xs = match x with None -> xs | Some x -> x :: xs
module Socket = Inuit.Socket
module Region = struct
type status = Ready | Locked
type 'flags t =
{ buffer: 'flags buffer
; left: Trope.cursor
; right: Trope.cursor
; parent: 'flags t
; observers:
( side
-> 'flags patch
-> 'flags list * (unit -> unit) option )
lazy_t
list
; mutable closed: bool }
and 'flags buffer =
{ mutable trope: 'flags t Trope.t
; mutable status: status
; mutable socket: 'flags Patch.t Socket.controller }
let unsafe_left_offset t = Trope.position t.buffer.trope t.left
let unsafe_right_offset t =
Trope.position t.buffer.trope t.right
let is_open t =
(not t.closed)
&& ( Trope.member t.buffer.trope t.right
||
( t.closed <- true ;
false ) )
let is_closed t = not (is_open t)
let notify_observers buffer side region ~stop_at patch =
assert (buffer.status = Ready) ;
let rec aux patch acc = function
| [] -> acc
| fs when fs == stop_at -> acc
| (lazy f) :: fs ->
let flags, f' = f side patch in
let patch = Patch.with_flags flags patch in
let acc = cons_some f' acc in
aux patch acc fs in
buffer.status <- Locked ;
let fs =
try aux patch [] region.observers
with exn ->
buffer.status <- Ready ;
raise exn in
buffer.status <- Ready ;
fs
let exec_observed fs = List.iter (fun f -> f ()) fs
let check_local_change name buffer =
match buffer.status with
| Locked ->
invalid_arg
( "Inuit_base.Region." ^ name
^ ": attempt to change locked buffer (buffer under \
observation)" )
| Ready -> ()
let region_parent region =
let parent = region.parent in
if parent == region then None else Some parent
let region_before trope cursor =
match Trope.find trope cursor with
| region when region.right == cursor -> Some region
| region -> region_parent region
| exception Not_found -> None
let region_after trope cursor =
match Trope.find trope cursor with
| region when region.left == cursor -> Some region
| region -> region_parent region
| exception Not_found -> None
let rec look_for_empty trope position cursor0 =
match Trope.seek_before trope cursor0 with
| Some (cursor, region)
when Trope.position trope cursor = position ->
if region.right == cursor0 then Some cursor
else look_for_empty trope position cursor
| _ -> None
let insertion_cursor ~left_leaning trope position =
match Trope.find_before trope position with
| None -> (position, None)
| Some (cursor0, region) -> (
match position - Trope.position trope cursor0 with
| n when n < 0 -> assert false
| 0 when left_leaning -> (
match look_for_empty trope position cursor0 with
| Some cursor -> (0, Some cursor)
| None -> (
if region.left == cursor0 then (0, Some cursor0)
else
match Trope.seek_before trope cursor0 with
| None -> (position, None)
| Some (cursor, _) ->
( position - Trope.position trope cursor
, Some cursor ) ) )
| n -> (n, Some cursor0) )
let replacement_bound trope position =
match Trope.find_after trope position with
| None -> None
| Some (cursor, _region) ->
Some (Trope.position trope cursor - position, cursor)
let ancestor_region l r =
let rec aux l r =
let c = Trope.compare l.left r.left in
if c < 0 then
match region_parent r with
| None -> None
| Some r' -> aux l r'
else if c > 0 then
match region_parent l with
| None -> None
| Some l' -> aux l' r
else Some l in
aux l r
let remote_replace b ({Patch.offset; _} as patch) old_len
new_len =
let trope = b.trope in
(* Find bounds *)
let left_offset, left_cursor =
insertion_cursor ~left_leaning:true trope offset in
let right_bound = replacement_bound trope (offset + old_len) in
(* Find affected regions and ancestor *)
let left_region =
match left_cursor with
| None -> None
| Some c -> region_after trope c in
let right_region =
match right_bound with
| None -> None
| Some (_, c) -> region_before trope c in
let ancestor =
match (left_region, right_region) with
| None, _ | _, None -> None
| Some l, Some r -> ancestor_region l r in
(* Notify observers *)
let left_o =
match left_region with
| None -> []
| Some region ->
notify_observers b `Remote region ~stop_at:[] patch
and right_o =
match right_region with
| None -> []
| Some right ->
let stop_at =
match ancestor with
| None -> []
| Some region -> region.observers in
notify_observers b `Remote right ~stop_at patch in
(* Update trope *)
let trope =
let trope =
match (left_cursor, right_bound) with
| Some l, Some (_, r) -> Trope.remove_between trope l r
| Some l, None ->
Trope.remove_after trope l (left_offset + old_len)
| None, Some (right_offset, r) ->
Trope.remove_before trope r
(left_offset + old_len + right_offset)
| None, None ->
Trope.remove trope ~at:0 ~len:(left_offset + old_len)
in
(* Reinsert cursors *)
let check =
match ancestor with
| None -> fun _ -> true
| Some region -> ( != ) region in
let rec reinsert_from_left trope = function
| Some region when check region ->
reinsert_from_left
(Trope.put_left trope region.right region)
(region_parent region)
| _ -> trope in
let rec reinsert_from_right trope = function
| Some region when check region ->
reinsert_from_right
(Trope.put_left trope region.left region)
(region_parent region)
| _ -> trope in
let trope = reinsert_from_left trope left_region in
let trope = reinsert_from_right trope right_region in
(* Fix padding *)
let trope =
match right_bound with
| None -> trope
| Some (offset, r) -> Trope.insert_before trope r offset
in
let trope =
match left_cursor with
| None ->
Trope.insert trope ~at:0 ~len:(left_offset + new_len)
| Some c ->
Trope.insert_after trope c (left_offset + new_len)
in
trope in
b.trope <- trope ;
exec_observed right_o ;
exec_observed left_o
let remote_propertize b ({Patch.offset; _} as patch) len =
let trope = b.trope in
(* Find bounds *)
let _left_offset, left_cursor =
insertion_cursor ~left_leaning:false trope offset in
let right_bound = replacement_bound trope (offset + len) in
(* Find affected regions and ancestor *)
let left_region =
match left_cursor with
| None -> None
| Some c -> region_after trope c in
let right_region =
match right_bound with
| None -> None
| Some (_, c) -> region_before trope c in
let ancestor =
match (left_region, right_region) with
| None, _ | _, None -> None
| Some l, Some r -> ancestor_region l r in
(* Notify observers *)
let left_o =
match left_region with
| None -> []
| Some region ->
notify_observers b `Remote region ~stop_at:[] patch
and right_o =
match right_region with
| None -> []
| Some right ->
let stop_at =
match ancestor with
| None -> []
| Some region -> region.observers in
notify_observers b `Remote right ~stop_at patch in
exec_observed right_o ; exec_observed left_o
let remote_insert b ({Patch.offset; _} as patch) new_len =
let trope = b.trope in
let left_offset, left_cursor =
insertion_cursor ~left_leaning:true trope offset in
let left_region =
match left_cursor with
| None -> None
| Some cursor -> region_after trope cursor in
let trope =
match left_cursor with
| None -> Trope.insert trope ~at:left_offset ~len:new_len
| Some cursor -> Trope.insert_after trope cursor new_len
in
let observed =
match left_region with
| None -> []
| Some region ->
notify_observers b `Remote region ~stop_at:[] patch
in
b.trope <- trope ;
exec_observed observed
let remote_change b patch =
match b.status with
| Locked ->
invalid_arg
"Inuit_base.Region.remote_change: attempt to change \
locked buffer (buffer under observation)"
| Ready -> (
let {Patch.operation; offset= _; text_len; flags= _} =
patch in
match operation with
| Patch.Remove n | Patch.Replace (n, _) ->
remote_replace b patch n text_len
| Patch.Insert _ -> remote_insert b patch text_len
| Patch.Propertize n -> remote_propertize b patch n )
let append t flags text =
if is_open t then (
let buffer = t.buffer in
check_local_change "append" buffer ;
let trope = buffer.trope in
let offset = Trope.position trope t.right in
let patch = Patch.make ~offset flags (Patch.Insert text) in
let observed =
notify_observers buffer `Local t ~stop_at:[] patch in
buffer.trope <-
Trope.insert_before trope t.right patch.Patch.text_len ;
Socket.send buffer.socket patch ;
exec_observed observed )
let generic_clear f t =
if is_open t then (
let buffer = t.buffer in
check_local_change "clear" buffer ;
let trope = buffer.trope in
let offset = Trope.position trope t.left in
let length = Trope.position trope t.right - offset in
F.epr " generic_clear: t.right=%d t.left=%d@."
(Trope.position trope t.left)
(Trope.position trope t.right) ;
let patch = Patch.make ~offset [] (Patch.Remove length) in
let observed =
notify_observers buffer `Local t ~stop_at:[] patch in
buffer.trope <- f t buffer.trope ;
Socket.send buffer.socket patch ;
exec_observed observed )
let clear t =
generic_clear
(fun t trope -> Trope.remove_between trope t.left t.right)
t
let kill t =
generic_clear
(fun t trope ->
let trope = Trope.remove_between trope t.left t.right in
let trope = Trope.rem_cursor trope t.left in
let trope = Trope.rem_cursor trope t.right in
trope )
t
let propertize flags t =
if is_open t then (
let buffer = t.buffer in
let trope = buffer.trope in
let offset = Trope.position trope t.left in
let length = Trope.position trope t.right - offset in
let patch =
Patch.make ~offset flags (Patch.Propertize length) in
let observed =
notify_observers buffer `Local t ~stop_at:[] patch in
Socket.send buffer.socket patch ;
exec_observed observed )
let sub ?(at = `Right) ?observer parent =
if is_open parent then (
let left =
match at with
| `Before -> Trope.cursor_before parent.left
| `Left -> Trope.cursor_after parent.left
| `Right -> Trope.cursor_before parent.right
| `After -> Trope.cursor_after parent.right in
let right = Trope.cursor_after left in
let parent =
match at with
| `Before | `After -> parent.parent
| `Left | `Right -> parent in
let buffer = parent.buffer in
let t' =
match observer with
| None ->
{ left
; right
; parent
; buffer
; closed= false
; observers= parent.observers }
| Some observer ->
let rec t' =
{ left
; right
; parent
; buffer
; closed= false
; observers= lazy (observer t') :: parent.observers
} in
t' in
let trope = buffer.trope in
let trope =
match at with
| `Right | `Before -> Trope.put_right trope left t'
| `Left | `After -> Trope.put_left trope left t' in
buffer.trope <- Trope.put_left trope right t' ;
(match t'.observers with [] -> () | (lazy _x) :: _ -> ()) ;
t' )
else parent
let make () =
let socket = Socket.make ~receive:ignore in
let trope = Trope.create () in
let left = Trope.cursor_at_origin trope in
let right = Trope.cursor_after left in
let rec t' =
{ left
; right
; buffer= {trope; status= Ready; socket}
; closed= false
; parent= t'
; observers= [] } in
let buffer = t'.buffer in
buffer.trope <-
Trope.put_left (Trope.put_left trope left t') right t' ;
Socket.set_receive socket (remote_change buffer) ;
Socket.set_on_closed socket (fun () ->
buffer.trope <- Trope.clear buffer.trope ) ;
(t', Socket.endpoint socket)
type 'flags observer =
'flags t
-> side
-> 'flags patch
-> 'flags list * (unit -> unit) option
end
module Inuit_region = Region
module Cursor = struct
type 'flags cursor =
{ region: 'flags Inuit_region.t
; flags: 'flags list
; indent: int }
type 'flags clickable = [> `Clickable | `Clicked] as 'flags
let indent_text col text =
if col <= 0 then text
else
List.flatten
(List.map
(function
| Format.Output_newline as r ->
[r; Format.Output_indent col]
| x -> [x] )
text )
let text t ?(flags = t.flags) text =
Inuit_region.append t.region flags (indent_text t.indent text)
let clear t = Inuit_region.clear t.region
let kill t = Inuit_region.kill t.region
let sub t = {t with region= Inuit_region.sub t.region}
let observe {region; flags; indent} f =
let observer region =
let t' = {region; flags; indent} in
fun side patch -> f t' side patch in
{region= Inuit_region.sub ~observer region; flags; indent}
let is_closed t = Inuit_region.is_closed t.region
let mem_flag flag cursor = List.mem flag cursor.flags
let add_flag flag cursor =
if mem_flag flag cursor then cursor
else {cursor with flags= flag :: cursor.flags}
let rem_flag flag cursor =
if mem_flag flag cursor then
{cursor with flags= List.filter (( <> ) flag) cursor.flags}
else cursor
let get_flags t = t.flags
let with_flags flags t = {t with flags}
let region t = t.region
let clickable t f =
let t = add_flag `Clickable t in
observe t (fun t' _side patch ->
let {Patch.flags; offset; _} = patch in
if
Inuit_region.unsafe_right_offset t'.region > offset
&& List.mem `Clicked flags
then
( List.filter (( <> ) `Clicked) flags
, Some (fun () -> f t') )
else (flags, None) )
let printf t ?flags fmt =
let sob = Format.make_symbolic_output_buffer () in
let pp = Format.formatter_of_symbolic_output_buffer sob in
Format.fprintf pp fmt ;
Format.pp_print_flush pp () ;
List.iter
(function
| Output_string s -> F.epr "printf: %s @." s | _ -> () )
(Format.get_symbolic_output_buffer sob) ;
text t ?flags (Format.flush_symbolic_output_buffer sob)
let link t ?flags fmt f =
let sob = Format.make_symbolic_output_buffer () in
let pp = Format.formatter_of_symbolic_output_buffer sob in
Format.fprintf pp fmt ;
Format.pp_print_flush pp () ;
text (clickable t f) ?flags
(Format.flush_symbolic_output_buffer sob)
let cursor_of_region ?(flags = []) ?(indent = 0) region =
{region; flags; indent}
let make () =
let region, pipe = Inuit_region.make () in
(cursor_of_region region, pipe)
let get_indent t = t.indent
let with_indent t indent = {t with indent}
let shift_indent t indent =
{t with indent= max 0 (t.indent + indent)}
end
let rec list_split i ?(left = []) = function
| [] -> (left, [])
| x :: xs ->
if i <= 0 then (left, x :: xs)
else list_split (i - 1) ~left:(left @ [x]) xs
module Edit = struct
open Cursor
type 'flags t =
{ mutable cursor: 'flags cursor
; mutable state: Format.symbolic_output_buffer }
let make ?(state = []) ?on_change cursor =
let t =
{cursor; state= Format.make_symbolic_output_buffer ()} in
let on_change =
match on_change with
| None -> None
| Some f -> Some (fun _ -> f t) in
printf (add_flag `Prompt cursor) "# " ;
t.cursor <-
observe cursor (fun cursor' side p ->
let s = Format.flush_symbolic_output_buffer t.state in
let offset =
p.Patch.offset
- Inuit_region.unsafe_left_offset (region cursor')
in
let sl, sr = list_split offset s in
List.iter
(Format.add_symbolic_output_item t.state)
(sl @ Patch.inserted_text p @ sr) ;
let callback =
if side = `Remote then on_change else None in
(p.Patch.flags, callback) ) ;
text t.cursor state ;
t
let change t ~state = clear t.cursor ; text t.cursor state
let state t = t.state
end
module Nav = struct
open Cursor
type 'flags t =
{ mutable prev: 'flags page list
; mutable page: 'flags page
; mutable next: 'flags page list
; frame: 'flags frame option }
and 'flags page = Patch.symbols * ('flags frame -> unit)
and 'flags frame =
{title: 'flags cursor; body: 'flags cursor; nav: 'flags t}
let make title body =
let page = (title, body) in
{prev= []; page; next= []; frame= None}
let update_frame t =
match t.frame with
| None -> ()
| Some ({title; body; nav= _} as frame) ->
clear title ;
text title (fst t.page) ;
F.epr "Nav.update_frame clear body@." ;
clear body ;
(snd t.page) frame
let goto t title body =
t.page <- (title, body) ;
t.next <- [] ;
update_frame t
let push t title body =
t.prev <- t.page :: t.prev ;
goto t title body
let next t =
match t.next with
| [] -> ()
| page :: pages ->
t.prev <- t.page :: t.prev ;
t.page <- page ;
t.next <- pages ;
update_frame t
let prev t =
match t.prev with
| [] -> ()
| page :: pages ->
t.next <- t.page :: t.next ;
t.page <- page ;
t.prev <- pages ;
update_frame t
let render_header t cursor =
(*⏪*)
(*↻*)
(*⏩*)
link cursor "[<<]" (fun _ -> prev t) ;
text cursor [Output_string " "] ;
link cursor "[reload]" (fun _ -> update_frame t) ;
text cursor [Output_string " "] ;
link cursor "[>>]" (fun _ -> next t)
let render t cursor =
let open Cursor in
if not (is_closed cursor) then (
let header = sub cursor in
printf cursor " " ;
let title = sub cursor in
printf cursor "\n\n" ;
let body = sub cursor in
let rec nav = {t with frame= Some frame}
and frame = {title; body; nav} in
render_header nav header ;
update_frame nav )
end
type flag =
[ `Clickable
| `Clicked
| `Editable
| `Prompt
| `Focus
| `Custom of string ]
type t =
{ mutable edit: flag Cursor.cursor
; mutable sock: flag Patch.t Socket.t
; mutable buf: Format.symbolic_output_item list
; mutable view: flag Nav.t
; mutable bind: Input.Bind.state }
let clear t = Cursor.clear t.edit
let insert t = Cursor.text t.edit
let contents t : Format.symbolic_output_item list = t.buf
let pr_sob s =
let sob = make_symbolic_output_buffer () in
let pp = formatter_of_symbolic_output_buffer sob in
F.pf pp s ;
flush_symbolic_output_buffer sob
let bindings _t =
let open Input.Bind in
add [([], Code Left)] [Zed Prev_char]
@@ add [([], Code Right)] [Zed Next_char]
@@ add [([], Code Up)] [Zed Prev_line]
@@ add [([], Code Down)] [Zed Next_line]
@@ add [([], Code Home)] [Zed Goto_bol]
@@ add [([], Code End)] [Zed Goto_eol]
@@ add [([], Code Insert)] [Zed Switch_erase_mode]
@@ add [([], Code Delete)] [Zed Delete_next_char]
@@ add [([], Code Enter)] [Zed Newline]
@@ add [([Ctrl], Char ' ')] [Zed Set_mark]
@@ add [([Ctrl], Char 'a')] [Zed Goto_bol]
@@ add [([Ctrl], Char 'e')] [Zed Goto_eol]
@@ add [([Ctrl], Char 'd')] [Zed Delete_next_char]
@@ add [([Ctrl], Char 'h')] [Zed Delete_prev_char]
@@ add [([Ctrl], Char 'k')] [Zed Kill_next_line]
@@ add [([Ctrl], Char 'u')] [Zed Kill_prev_line]
@@ add [([Ctrl], Char 'n')] [Zed Next_line]
@@ add [([Ctrl], Char 'p')] [Zed Prev_line]
@@ add [([Ctrl], Char 'w')] [Zed Kill]
@@ add [([Ctrl], Char 'y')] [Zed Yank]
@@ add [([], Code Backspace)] [Zed Delete_prev_char]
@@ add [([Meta], Char 'w')] [Zed Copy]
@@ add [([Meta], Char 'c')] [Zed Capitalize_word]
@@ add [([Meta], Char 'l')] [Zed Lowercase_word]
@@ add [([Meta], Char 'u')] [Zed Uppercase_word]
@@ add [([Meta], Char 'b')] [Zed Prev_word]
@@ add [([Meta], Char 'f')] [Zed Next_word]
@@ add [([Meta], Code Right)] [Zed Next_word]
@@ add [([Meta], Code Left)] [Zed Prev_word]
@@ add [([Ctrl], Code Right)] [Zed Next_word]
@@ add [([Ctrl], Code Left)] [Zed Prev_word]
@@ add [([Meta], Code Backspace)] [Zed Kill_prev_word]
@@ add [([Meta], Code Delete)] [Zed Kill_prev_word]
@@ add [([Ctrl], Code Delete)] [Zed Kill_next_word]
@@ add [([Meta], Char 'd')] [Zed Kill_next_word]
@@ add [([Ctrl], Char '/')] [Zed Undo]
@@ add [([Ctrl], Char 'x'); ([], Char 'u')] [Zed Undo]
@@ add [([Ctrl], Char 'v')] [Custom (fun () -> ())]
@@ add [([Meta], Char 'v')] [Custom (fun () -> ())]
@@ empty
let make ?(bindings = bindings) ?on_change main =
let open Cursor in
let edit, sock = Cursor.make () in
let t =
{ edit
; sock
; buf= []
; view=
( F.epr "Nav.make@." ;
Nav.make (pr_sob "MR. DERPSALOT")
@@ fun {Nav.title= _; body; nav} ->
let open Cursor in
printf body "Je mens.@.@." ;
link body "- C'est vrai." (fun _ ->
Nav.push nav (pr_sob "C'est vrai !")
@@ fun {Nav.body; _} -> printf body "C'est faux." ) ;
printf body "@." ;
link body "- C'est faux." (fun _ ->
Nav.push nav (pr_sob "C'est faux !")
@@ fun {Nav.body; _} -> printf body "C'est vrai." ) ;
printf body "@." ;
printf body main ;
F.epr "Nav.make callback@." )
; bind= Input.Bind.init Input.Bind.empty } in
let sock' =
Socket.make (*~receive:ignore*)
~receive:
Patch.(
fun p ->
F.epr "Patch.t {offset=%d, operation=" p.offset ;
match p.operation with
| Insert s ->
F.epr "Insert (sob len %d) \"" (List.length s) ;
format_symbolic_output_items F.stderr s ;
F.epr "\"@."
| Replace (i, s) ->
F.epr "Replace %d \"" i ;
format_symbolic_output_items F.stderr s ;
F.epr "\"@."
| Remove i -> F.epr "Remove %d@." i
| Propertize i ->
F.epr "Propertize %d@." i ;
F.epr ", text_len=%d}@." p.text_len) in
Socket.connect ~a:t.sock ~b:(Socket.endpoint sock') ;
printf (add_flag `Prompt edit) "# " ;
Cursor.printf edit main ;
t.edit <-
observe edit (fun cursor' side p ->
let offset =
p.Patch.offset
- Inuit_region.unsafe_left_offset (region cursor') in
F.epr
"observe edit: (length t.buf)=%d; offset=(p.offset=%d \
- unsafe_left_offset=%d)=%d @."
(List.length t.buf) p.Patch.offset
(Inuit_region.unsafe_left_offset (region cursor'))
offset ;
( match p.operation with
| Insert _ ->
let sl, sr = list_split offset t.buf in
t.buf <- sl @ Patch.inserted_text p @ sr
| Replace (i, _) | Remove i ->
let sl, sr = list_split offset t.buf in
let _, sr = list_split i sr in
t.buf <- sl @ Patch.inserted_text p @ sr
| Propertize i -> F.epr "Propertize %d@." i ) ;
let callback =
if side = `Remote then on_change else None in
(p.Patch.flags, callback) ) ;
t.bind.bindings <- bindings t ;
t
let panel ?(height = !g_text_height) t =
Lwt.return
{ act=
(fun _panel events ->
(* collect events and update Zed context *)
let open Input.Bind in
Lwt_list.iter_s
(function
| Custom f -> f () ; Lwt.return_unit
| CustomLwt f -> f ()
| _ -> Lwt.return_unit )
(actions_of_events t.bind events)
>>= fun () ->
Lwt_list.iter_s
(function
| `Text_input _s -> Lwt.return_unit
| _ -> Lwt.return_unit )
events
>>= fun () ->
Nav.render t.view t.edit ;
Lwt.return
(draw_pp height (fun pp ->
Format.pp_open_hvbox pp 0 ;
format_symbolic_output_items pp (contents t) ;
F.pf pp "@." ;
Format.pp_close_box pp () ) ) )
; subpanels= []
; tag= "textedit" }
end
module Modal = struct
type t =
{ te: Textedit.t
; mutable input: string option
; mutable handle: string -> unit
; mutable prompt: string }
let make () =
{ te= Textedit.make "" ()
; input= None
; handle= (fun _text -> ())
; prompt= "" }
let panel ?(height = !g_text_height) me =
let keybinds =
let open Input.Bind in
add [([], Code Enter)]
[ Custom
(fun () ->
(* set input first so a modal can trigger another modal *)
me.input <- None ;
me.handle (Textedit.contents me.te) ) ]
(Textedit.bindings me.te) in
me.te.keybind.bindings <- keybinds ;
Lwt.return
{ act=
(fun panel events ->
match me.input with
| Some text ->
Textedit.insert me.te text ;
hbox panel.subpanels >>= fun p -> p.act panel events
| None -> Lwt.return Display.pane_empty
(* don't draw anything if modal isn't active *) )
; subpanels=
[ prettyprint (fun pp -> F.text pp me.prompt)
; Textedit.panel ~height me.te ]
; tag= "modal-edit" }
let start me ?(prompt = "> ") text handler =
me.input <- Some text ;
Textedit.clear me.te ;
Textedit.insert me.te text ;
me.handle <- handler ;
me.prompt <- prompt
let is_active me =
match me.input with Some _ -> true | None -> false
end
end
module Toplevel = struct
type t =
{mutable eval: Topinf.evalenv; res: Format.symbolic_output_buffer}
let init () =
let sob = Format.make_symbolic_output_buffer () in
Topinf.ppf := Format.formatter_of_symbolic_output_buffer sob ;
{eval= !Topinf.eval; res= sob}
let eval t str =
let ppf = Format.formatter_of_symbolic_output_buffer t.res in
Topinf.ppf := ppf ;
ignore (Format.flush_symbolic_output_buffer t.res) ;
try
t.eval ppf (str ^ ";;") ;
(*HACK to prevent getting stuck in parser*)
let b = Buffer.create 69 in
Panel.format_symbolic_output_buffer
(Format.formatter_of_buffer b)
t.res
with e ->
F.pf ppf "Exception in pane_top//eval@." ;
Location.report_exception ppf e ;
F.epr "Exception in pane_top//eval@."
let result_sob t = t.res
end
module Store = struct
module Istore = Irmin_unix.Git.FS.KV (Irmin.Contents.String)
(* storeview shows items of the selected level *)
type storeview =
{ store: Istore.t
; mutable view: Istore.key
; mutable selection: Istore.key
; mutable editmode: bool
; sob: Format.symbolic_output_buffer }
let make_storeview ?(path = []) storepath branch =
Istore.Repo.v (Irmin_git.config storepath)
>>= fun repo ->
Istore.of_branch repo branch
>>= fun store ->
let view = Istore.Key.v path in
Istore.list store view
>>= fun viewlist ->
Lwt.return
{ store
; view
; selection= Istore.Key.v [fst (List.hd viewlist)]
; editmode= false
; sob= Format.make_symbolic_output_buffer () }
let directives (top : Toplevel.t) sv =
let dir_use_key key_lid =
(* TODO: currently causes a segfault :( *)
let key_obj =
try
match
Env.find_value_by_name key_lid !Topinf.toplevel_env
with
| path, _desc ->
Topinf.eval_value_path !Topinf.toplevel_env path
| exception Not_found ->
F.epr "Unbound value %a.@." Printtyp.longident key_lid ;
raise Exit
with Exit -> Obj.repr ["nofile"] in
let key = Obj.obj key_obj in
let contents =
Lwt_main.run
( Istore.kind sv.store key
>>= function
| Some a -> (
match a with
| `Contents -> Istore.get sv.store key
| `Node ->
Lwt.return "\"use_key on Node not implemented yet\"" )
| None -> Lwt.return "Invalid Selection..." ) in
Toplevel.eval top contents in
Topinf.add_directive "use_key" (Directive_ident dir_use_key)
{ section= "Console Store"
; doc=
"Read, compile and execute source phrases from the given \
store key." }
let navigate sv action =
let rec findi value = function
| [] -> 0
| a :: b -> (if a = value then -1 else findi value b) + 1 in
fun () ->
Istore.get_tree sv.store sv.view
>>= fun top ->
match Istore.Key.rdecons sv.selection with
| Some (ppath, step) ->
Istore.Tree.list top ppath
>>= fun neighbors ->
let steplist = fst (List.split neighbors) in
let stepi = findi step steplist in
Istore.Tree.list (snd (List.nth neighbors stepi)) []
>>= fun subtreelist ->
Lwt.return
( match action with
| `Next ->
let stepi = findi step steplist in
if List.length steplist - 1 > stepi then
sv.selection <-
Istore.Key.rcons ppath
(List.nth steplist (stepi + 1))
| `Prev ->
if stepi > 0 then
sv.selection <-
Istore.Key.rcons ppath
(List.nth steplist (stepi - 1))
| `Sub ->
if List.length subtreelist > 0 then
sv.selection <-
sv.selection @ [fst (List.hd subtreelist)]
| `Sup ->
if List.length ppath > 0 then sv.selection <- ppath )
| None -> Lwt.return_unit
let editor ?(branch = "current") storepath : Panel.t Lwt.t =
make_storeview storepath branch
>>= fun sv ->
let top = Toplevel.init () in
let modalstate = Panel.Modal.make () in
let te = Panel.Textedit.make "" () in
let save store path content =
Lwt.async (fun () ->
Istore.set_exn store
~info:(Irmin_unix.info "editor-save")
path content ) in
let editbinds =
let open Input.Bind in
add
[([Ctrl], Char 'c')]
[ Custom
(fun () ->
sv.editmode <- not sv.editmode ;
save sv.store
(sv.view @ sv.selection)
(Panel.Textedit.contents te) ) ]
@@ add
[([Ctrl], Char 's')]
[ Custom
(fun () ->
save sv.store
(sv.view @ sv.selection)
(Panel.Textedit.contents te) ) ]
@@ add
[([Ctrl], Char 'x'); ([], Char 'x')]
[ Custom
(fun () ->
Toplevel.eval top (Panel.Textedit.contents te) ) ]
(Panel.Textedit.bindings te) in
te.keybind.bindings <- editbinds ;
let is_node path =
Istore.get_tree sv.store sv.view
>>= fun t ->
Istore.Tree.kind t path
>>= function
| Some `Node -> Lwt.return_true | _ -> Lwt.return_false in
let update_storeview () =
ignore (Format.flush_symbolic_output_buffer sv.sob) ;
let pp = Format.formatter_of_symbolic_output_buffer sv.sob in
let rec draw_levels ?(indent = 0) (sel : Istore.key)
(tree : Istore.tree) : unit Lwt.t =
Istore.Tree.list tree []
>>= Lwt_list.iteri_s (fun _i (step, node) ->
Format.pp_open_box pp indent ;
if sel = [step] then (
Format.pp_open_stag pp
(Panel.Cursor (Wall.Color.v 0.99 0.99 0.125 0.3)) ;
F.pf pp "@," ;
Format.pp_close_stag pp () ) ;
Istore.Tree.kind node []
>>= fun k ->
( match k with
| Some `Contents ->
F.pf pp "- %s@." step ; Lwt.return_unit
| Some `Node ->
F.pf pp "> %s@." step ;
let subsel =
match Istore.Key.decons sel with
| Some (_tstep, subkey) -> subkey
| None -> [] in
Format.pp_open_vbox pp 0 ;
draw_levels ~indent:(indent + 1) subsel node
>>= fun () ->
Format.pp_close_box pp () ;
Lwt.return_unit
| None -> F.pf pp "ERROR: None" ; Lwt.return_unit )
>>= fun () ->
Format.pp_close_box pp () ;
Lwt.return_unit ) in
Istore.get_tree sv.store sv.view >>= draw_levels sv.selection
in
let update_textedit () =
Panel.Textedit.clear te ;
Istore.get_tree sv.store sv.view
>>= fun t ->
Istore.Tree.kind t sv.selection
>>= function
| Some `Contents ->
Istore.Tree.get t sv.selection
>>= fun content ->
Panel.Textedit.insert te content ;
Lwt.return_unit
| Some `Node ->
Panel.Textedit.insert te "Node..." ;
Lwt.return_unit
| None -> Lwt.return_unit in
let navbinds =
let open Input.Bind in
let new_contents name content =
Lwt.async (fun () ->
let s =
match Istore.Key.rdecons sv.selection with
| Some (t, _) -> t
| None -> Istore.Key.empty in
Istore.get_tree sv.store (sv.view @ s)
>>= fun tree ->
Istore.Tree.add tree name content
>>= fun newtree ->
Istore.set_tree_exn
~info:(Irmin_unix.info "new Contents")
sv.store sv.view newtree ) in
add [([], Char 'n')] [CustomLwt (navigate sv `Next)]
@@ add [([], Char 'p')] [CustomLwt (navigate sv `Prev)]
@@ add [([], Char 'w')] [CustomLwt (navigate sv `Prev)]
@@ add [([], Char 's')] [CustomLwt (navigate sv `Next)]
@@ add [([], Char 'd')] [CustomLwt (navigate sv `Sub)]
@@ add [([], Char 'a')] [CustomLwt (navigate sv `Sup)]
@@ add
[([], Char 'e')] (* enter edit mode *)
[ Custom
(fun () ->
Lwt.async (fun () ->
is_node sv.selection
>>= fun nb ->
if not nb then sv.editmode <- not sv.editmode ;
Lwt.return_unit ) ) ]
@@ add
[([], Char 'f')] (* find: enter path in modal *)
[Custom (fun () -> ())]
@@ add
[([], Char 'c')] (* contents: create new contents node *)
[ Custom
(fun () ->
Panel.Modal.start ~prompt:"Contents name > "
modalstate "" (fun name ->
new_contents (Istore.Key.v [name]) "" ) ) ]
@@ add
[([], Char 't')] (* tree: create new subtree *)
[ Custom
(fun () ->
Panel.Modal.start ~prompt:"Node name > " modalstate
"" (fun nodename ->
Panel.Modal.start
~prompt:"Initial Contents name > " modalstate
"" (fun contentsname ->
new_contents
(Istore.Key.v [nodename; contentsname])
"" ) ) ) ]
@@ add
[([], Char 'r')] (* remove contents/node *)
[ CustomLwt
(fun () ->
let selection = sv.selection in
navigate sv `Next ()
>>= fun () ->
Istore.get_tree sv.store sv.view
>>= fun tree ->
Istore.Tree.remove tree selection
>>= fun newtree ->
Istore.set_tree_exn
~info:(Irmin_unix.info "remove Contents/Node")
sv.store sv.view newtree ) ]
@@ add
[([], Char 'x')] (* execute contents/node *)
[ Custom
(fun () ->
Toplevel.eval top (Panel.Textedit.contents te) ) ]
empty in
let bindstate = Input.Bind.init navbinds in
Lwt.return
Panel.
{ act=
(fun panel events ->
( if
(not sv.editmode)
&& not (Panel.Modal.is_active modalstate)
then
Input.Bind.process bindstate events
>>= fun () ->
Lwt.join [update_storeview (); update_textedit ()]
else Lwt.return_unit )
>>= fun () ->
Panel.vbox panel.subpanels
>>= fun p -> p.act panel events )
; subpanels=
[ Panel.filter_events
(fun ev ->
if Panel.Modal.is_active modalstate then ev else []
)
(Panel.Modal.panel modalstate)
; Panel.hbox
[ Panel.prettyprint (fun pp ->
Panel.format_symbolic_output_buffer pp sv.sob )
; Panel.vbox
[ Panel.filter_events
(fun ev -> if sv.editmode then ev else [])
(Panel.Textedit.panel te)
; Panel.prettyprint (fun pp ->
Format.pp_open_hovbox pp 0 ;
Panel.format_symbolic_output_buffer pp
(Toplevel.result_sob top) ;
Format.pp_close_box pp () ;
F.flush pp () ) ] ]
; Panel.Textedit.bindingstate bindstate
; Panel.prettyprint (fun pp ->
Format.fprintf pp "sv.editmode = %b @." sv.editmode )
]
; tag= "store-editor" }
end
let std_actor (root_panel : Panel.t Lwt.t) =
Panel.actor
(Panel.obox
[ Panel.draw (fun (s : Display.state) ->
(s, Display.fill_box (Display.gray 0.125) s.box) )
; root_panel ] )
let root_actor = ref (std_actor (Store.editor "../rootstore"))
open Panel
let inuit_test =
let t = InuitTextedit.make " TEST @. What @. Help @." in
InuitTextedit.panel t
let start () =
root_actor := std_actor inuit_test ;
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. *)
Reference in New Issue View Git Blame Copy Permalink