console/boot
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Files
d6b16f2a4e14b770f9e47c642b9119ba2e56aa95
boot/main.ml
cqc d6b16f2a4e actually seperate act from render
2021-09-01 05:05:48 -05:00

1127 lines
36 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 Store = Irmin_unix.Git.FS.KV (Irmin.Contents.String)
module Input = struct
open CamomileLibrary
open Zed_edit
open CamomileLibrary
(** Type of key code. *)
type code =
| Char of UChar.t (** A unicode character. *)
| Enter
| Escape
| Tab
| Up
| Down
| Left
| Right
| F1
| F2
| F3
| F4
| F5
| F6
| F7
| F8
| F9
| F10
| F11
| F12
| Next_page
| Prev_page
| Home
| End
| Insert
| Delete
| Backspace
| Unknown
| None
module KeymodSet = struct
type t = Shift | Ctrl | Meta | Fn
let compare (x : t) (y : t) = compare x y
end
module Keymod = Set.Make (KeymodSet)
type key = {mods: Keymod.t; code: code}
module Key = struct
type t = key
let compare (x : t) (y : t) = compare x y
end
module Bind = struct
module S = Zed_input.Make (Key)
include S
type action = Custom of (unit -> unit) | Zed of Zed_edit.action
type binding = key * action list
type bindings = binding list
(* stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *)
type t = action list S.t
type resolver = action list S.resolver
type result = action list S.result
let default_resolver b =
resolver [pack (fun (x : action list) -> x) b]
let get_resolver result default =
match result with Continue r -> r | _ -> default
let handle_actions actions zectx =
List.iter
(function
| Custom f -> f () | Zed za -> Zed_edit.get_action za zectx
)
actions
end
(* stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *)
let string_of_code = function
| Char ch -> Printf.sprintf "Char 0x%02x" (UChar.code ch)
| Enter -> "Enter"
| Escape -> "Escape"
| Tab -> "Tab"
| Up -> "Up"
| Down -> "Down"
| Left -> "Left"
| Right -> "Right"
| F1 -> "F1"
| F2 -> "F2"
| F3 -> "F3"
| F4 -> "F4"
| F5 -> "F5"
| F6 -> "F6"
| F7 -> "F7"
| F8 -> "F8"
| F9 -> "F9"
| F10 -> "F10"
| F11 -> "F11"
| F12 -> "F12"
| Next_page -> "Next_page"
| Prev_page -> "Prev_page"
| Home -> "Home"
| End -> "End"
| Insert -> "Insert"
| Delete -> "Delete"
| Backspace -> "Backspace"
| Unknown -> "Unknown"
| None -> "None"
let to_string key =
Printf.sprintf
"{ control = %B; meta = %B; shift = %B; fn = %B; code = %s }"
(Keymod.mem Ctrl key.mods)
(Keymod.mem Meta key.mods)
(Keymod.mem Shift key.mods)
(Keymod.mem Fn key.mods)
(string_of_code key.code)
let to_string_compact key =
let buffer = Buffer.create 32 in
if Keymod.mem Ctrl key.mods then Buffer.add_string buffer "C-" ;
if Keymod.mem Meta key.mods then Buffer.add_string buffer "M-" ;
if Keymod.mem Shift key.mods then Buffer.add_string buffer "S-" ;
if Keymod.mem Fn key.mods then Buffer.add_string buffer "Fn-" ;
( match key.code with
| Char ch ->
let code = UChar.code ch in
if code <= 255 then
match Char.chr code with
| ( 'a' .. 'z'
| 'A' .. 'Z'
| '0' .. '9'
| '_' | '(' | ')' | '[' | ']' | '{' | '}' | '#' | '~'
| '&' | '$' | '*' | '%' | '!' | '?' | ',' | ';' | ':'
| '/' | '\\' | '.' | '@' | '=' | '+' | '-' ) as ch ->
Buffer.add_char buffer ch
| ' ' -> Buffer.add_string buffer "space"
| _ -> Printf.bprintf buffer "U+%02x" code
else if code <= 0xffff then
Printf.bprintf buffer "U+%04x" code
else Printf.bprintf buffer "U+%06x" code
| Next_page -> Buffer.add_string buffer "next"
| Prev_page -> Buffer.add_string buffer "prev"
| code ->
Buffer.add_string buffer
(String.lowercase_ascii (string_of_code code)) ) ;
Buffer.contents buffer
end
module Event = struct
open Tsdl
open CamomileLibrary
open Zed_edit
open Input
open Input.KeymodSet
type mouse = int * int
type t =
[ `Key_down of Input.key
| `Key_up of Input.key
| `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 km = Sdl.Event.get ev Sdl.Event.keyboard_keymod in
let (kc : Sdl.keycode) =
Sdl.Event.get ev Sdl.Event.keyboard_keycode
land lnot Sdl.K.scancode_mask in
let open Sdl.K in
let (c : Input.code) =
match (kc : Sdl.keycode) with
(* HACK WHENENENENENENENENEHWEHWEHNWEWHWEHWEN FUCK X WHEN X whatS>!!>!> *)
| x when x = return -> Enter
| x when x = escape -> Escape
| x when x = backspace -> Backspace
| x when x = tab -> Tab
| x when x = f1 -> F1
| x when x = f2 -> F2
| x when x = f3 -> F3
| x when x = f4 -> F4
| x when x = f5 -> F5
| x when x = f6 -> F6
| x when x = f7 -> F7
| x when x = f8 -> F8
| x when x = f9 -> F9
| x when x = f10 -> F10
| x when x = f11 -> F11
| x when x = f12 -> F12
| x when x = insert -> Insert
| x when x = delete -> Delete
| x when x = home -> Home
| x when x = kend -> End
| x when x = pageup -> Prev_page
| x when x = pagedown -> Next_page
| x when x = right -> Right
| x when x = left -> Left
| x when x = down -> Down
| x when x = up -> Up
| k -> (
match UChar.char_of (UChar.of_int k) with
| 'a' .. 'z'
|'A' .. 'Z'
|'0' .. '9'
|'_' | '(' | ')' | '[' | ']' | '{' | '}' | '#' | '~'
|'&' | '$' | '*' | '%' | '!' | '?' | ',' | ';' | ':'
|'/' | '\\' | '.' | '@' | '=' | '+' | '-' | ' ' | '"'
|'\'' | '>' | '<' | '^' | '`' | '|' ->
Char (UChar.of_int k)
| _ -> None ) in
let mods =
List.filter_map
(fun (m, v) -> if km land m > 0 then Some v else None)
Sdl.Kmod.
[(shift, Shift); (ctrl, Ctrl); (alt, Meta); (gui, Fn)]
in
{code= c; mods= Input.Keymod.of_list mods} in
let repeat = Sdl.Event.get ev Sdl.Event.keyboard_repeat in
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 CamomileLibrary
open Zed_edit
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
let image_empty : image = (Box2.empty, Image.empty)
type pane = state -> state * image
let pane_empty s = (s, image_empty)
type frame =
{ sdl_win: Sdl.window
; gl: Sdl.gl_context
; wall: Wall.renderer
; 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} )
~cleanup:(fun () -> Sdl.destroy_window sdl_win)
let get_events () =
(* create and fill event list *)
let ev = Sdl.Event.create () in
let el = ref [`None] in
while Sdl.wait_event_timeout (Some ev) 50 (* HACK *) do
let e = Event.event_of_sdlevent ev in
if e != `None then el := !el @ [e]
(* HACK? *)
done ;
!el
let last_pane = ref pane_empty
let display_frame frame actor =
let events =
(* Handle relevant events *)
List.filter_map
(function
| `Quit ->
frame.quit <- true ;
None
| `Fullscreen a ->
if a then (
frame.fullscreen <- not frame.fullscreen ;
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 ) ) ;
None
| a -> Some a (*| a -> Some a*) )
(get_events ()) in
let width, height = Sdl.gl_get_drawable_size frame.sdl_win in
if List.length events > 0 then last_pane := actor events ;
let _, (_, image) =
!last_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 run frame render () =
let frame = get_result frame in
Sdl.show_window frame.sdl_win ;
while not frame.quit do
ignore (display_frame frame render)
done ;
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 Wall
open Gg
type t =
{ act: t -> Event.events -> t * Display.pane
; subpanels: t list
; tag: string }
type actor = Event.events -> Display.pane
let blank =
{ act=
(fun panel _events ->
(panel, fun s -> (s, Display.image_empty)) )
; subpanels= []
; tag= "blank pane" }
let draw (pane : Display.pane) =
{ act= (fun panel _events -> (panel, pane))
; subpanels= []
; tag= "draw-pane" }
(* draws subsequent items below *)
let vbox subpanels =
{ act=
(fun panel events ->
( panel
, pane_box Box2.tl_pt
(* tl_pt is actually bl_pt in the Wall coordinate system *)
(List.map
(fun subpanel -> snd (subpanel.act subpanel events))
panel.subpanels ) ) )
; subpanels
; tag= "vertical-box" }
(* draws subsequent item to the right *)
let hbox subpanels =
{ act=
(fun panel events ->
( panel
, pane_box Box2.br_pt
(* br_pt is actually tr_pt in the Wall coordinate system *)
(List.map
(fun subpanel -> snd (subpanel.act subpanel events))
panel.subpanels ) ) )
; subpanels
; tag= "horizontal-box" }
(* draws subsequent panels overtop each other *)
let obox subpanels =
{ act=
(fun panel events ->
( panel
, pane_box Box2.o
(List.map
(fun subpanel -> snd (subpanel.act subpanel events))
panel.subpanels ) ) )
; subpanels
; tag= "origin-box" }
let g_text_height = ref 30.
type Format.stag += Color_bg of Wall.color
type Format.stag += Color_fg of Wall.color
type Format.stag += Cursor of Wall.color
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 default_bindings =
let open Input.Bind in
let open CamomileLibrary in
let open Zed_edit in
let m = Input.Keymod.of_list in
let b = ref empty in
let add e a = b := Input.Bind.add e a !b in
add [{mods= m []; code= Left}] [Zed Prev_char] ;
add [{mods= m []; code= Right}] [Zed Next_char] ;
add [{mods= m []; code= Up}] [Zed Prev_line] ;
add [{mods= m []; code= Down}] [Zed Next_line] ;
add [{mods= m []; code= Home}] [Zed Goto_bol] ;
add [{mods= m []; code= End}] [Zed Goto_eol] ;
add [{mods= m []; code= Insert}] [Zed Switch_erase_mode] ;
add [{mods= m []; code= Delete}] [Zed Delete_next_char] ;
add [{mods= m []; code= Enter}] [Zed Newline] ;
add
[{mods= m [Ctrl]; code= Char (UChar.of_char ' ')}]
[Zed Set_mark] ;
add
[{mods= m [Ctrl]; code= Char (UChar.of_char 'a')}]
[Zed Goto_bol] ;
add
[{mods= m [Ctrl]; code= Char (UChar.of_char 'e')}]
[Zed Goto_eol] ;
add
[{mods= m [Ctrl]; code= Char (UChar.of_char 'd')}]
[Zed Delete_next_char] ;
add
[{mods= m [Ctrl]; code= Char (UChar.of_char 'h')}]
[Zed Delete_prev_char] ;
add
[{mods= m [Ctrl]; code= Char (UChar.of_char 'k')}]
[Zed Kill_next_line] ;
add
[{mods= m [Ctrl]; code= Char (UChar.of_char 'u')}]
[Zed Kill_prev_line] ;
add
[{mods= m [Ctrl]; code= Char (UChar.of_char 'n')}]
[Zed Next_line] ;
add
[{mods= m [Ctrl]; code= Char (UChar.of_char 'p')}]
[Zed Prev_line] ;
add [{mods= m [Ctrl]; code= Char (UChar.of_char 'w')}] [Zed Kill] ;
add [{mods= m [Ctrl]; code= Char (UChar.of_char 'y')}] [Zed Yank] ;
add [{mods= m []; code= Backspace}] [Zed Delete_prev_char] ;
add [{mods= m [Meta]; code= Char (UChar.of_char 'w')}] [Zed Copy] ;
add
[{mods= m [Meta]; code= Char (UChar.of_char 'c')}]
[Zed Capitalize_word] ;
add
[{mods= m [Meta]; code= Char (UChar.of_char 'l')}]
[Zed Lowercase_word] ;
add
[{mods= m [Meta]; code= Char (UChar.of_char 'u')}]
[Zed Uppercase_word] ;
add
[{mods= m [Meta]; code= Char (UChar.of_char 'b')}]
[Zed Prev_word] ;
add
[{mods= m [Meta]; code= Char (UChar.of_char 'f')}]
[Zed Next_word] ;
add [{mods= m [Meta]; code= Right}] [Zed Next_word] ;
add [{mods= m [Meta]; code= Left}] [Zed Prev_word] ;
add [{mods= m [Ctrl]; code= Right}] [Zed Next_word] ;
add [{mods= m [Ctrl]; code= Left}] [Zed Prev_word] ;
add [{mods= m [Meta]; code= Backspace}] [Zed Kill_prev_word] ;
add [{mods= m [Meta]; code= Delete}] [Zed Kill_prev_word] ;
add [{mods= m [Ctrl]; code= Delete}] [Zed Kill_next_word] ;
add
[{mods= m [Meta]; code= Char (UChar.of_char 'd')}]
[Zed Kill_next_word] ;
add [{mods= m [Ctrl]; code= Char (UChar.of_char '/')}] [Zed Undo] ;
add
[ {mods= m [Ctrl]; code= Char (UChar.of_char 'x')}
; {mods= m []; code= Char (UChar.of_char 'u')} ]
[Zed Undo] ;
!b
type textedit =
{ ze: unit Zed_edit.t
; zc: Zed_cursor.t
; mutable bindings: Input.Bind.t
; mutable binding_state: Input.Bind.result
; mutable last_keyseq: Input.key list
; mutable last_actions: Input.Bind.action list }
let make_textedit () =
let z = Zed_edit.create () in
{ ze= z
; zc= Zed_edit.new_cursor z
; bindings= default_bindings
; binding_state= Input.Bind.S.Rejected
; last_keyseq= [{mods= Input.Keymod.empty; code= Input.None}]
; last_actions= [] }
(* pane that displays last key binding match state *)
let draw_textedit_input height (te : textedit) =
draw_pp height (fun pp ->
Format.pp_open_hbox pp () ;
F.text pp
(List.fold_right
(fun x s -> Input.to_string_compact x ^ " " ^ s)
te.last_keyseq "" ) ;
F.text pp
(List.fold_right
(fun x s ->
s ^ "-> "
^ Input.Bind.(
match x with
| Zed a -> Zed_edit.name_of_action a
| Custom _ -> "Custom") )
te.last_actions "" ) ;
Format.pp_close_box pp () ;
F.flush pp () )
let str_of_textedit (te : textedit) =
Zed_string.to_utf8 (Zed_rope.to_string (Zed_edit.text te.ze))
let textedit ?(_keybinds : Input.Bind.bindings = [])
?(_initialstring = "") ?(height = !g_text_height) te =
{ act=
(fun panel events ->
let ctx = Zed_edit.context te.ze te.zc in
(* collect events and update Zed context *)
List.iter
(function
| `Key_down (k : Input.key) -> (
let open Input.Bind in
( match te.binding_state with
| Accepted _ | Rejected ->
te.last_keyseq <- [] ;
te.last_actions <- []
| Continue _ -> () ) ;
te.binding_state <-
resolve k
(get_resolver te.binding_state
(default_resolver te.bindings) ) ;
te.last_keyseq <- k :: te.last_keyseq ;
match te.binding_state with
| Accepted a ->
te.last_actions <- a ;
List.iter
(function
| Input.Bind.Custom f -> f ()
| Zed za -> Zed_edit.get_action za ctx )
a
| Continue _ -> ()
| Rejected -> () )
| `Key_up _ -> ()
| `Text_input s ->
Zed_edit.insert ctx
(Zed_rope.of_string (Zed_string.of_utf8 s))
| _ -> () )
events ;
let draw_textedit =
draw_pp height (fun pp ->
let zrb, zra =
Zed_rope.break (Zed_edit.text te.ze)
(Zed_cursor.get_position te.zc) in
let before_cursor =
Zed_string.to_utf8 (Zed_rope.to_string zrb) in
let after_cursor =
Zed_string.to_utf8 (Zed_rope.to_string zra) in
Format.pp_open_hvbox pp 0 ;
F.text pp before_cursor ;
Format.pp_open_stag pp
Display.(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
(panel, draw_textedit) )
; subpanels= []
; tag= "textedit" }
let prettyprint ?(height = !g_text_height) fpp =
{ act= (fun panel _events -> (panel, draw_pp height fpp))
; subpanels= []
; tag= "pretty-print" }
let enclosure = ref blank
let actor (panel : t) : Event.events -> Display.pane =
enclosure := panel ;
fun events ->
let panel, pane = panel.act !enclosure events in
enclosure := panel ;
pane
end
open Wall
open Gg
module I = Image
module P = Path
module Text = Wall_text
type storeview = {s: Store.t; path: string list}
let make_storeview storepath branch ?(path = []) () =
{ s=
Lwt_main.run
(Store.of_branch
(Lwt_main.run (Store.Repo.v (Irmin_git.config storepath)))
branch )
; path }
let draw_storeview (r : storeview) height (s : Display.state) =
let indent = ref 0 in
let rec draw_levels (tree : (string * Store.tree) list) pp =
indent := !indent + 1 ;
List.iter
(fun (step, node) ->
Format.pp_open_vbox pp 0 ;
Format.pp_open_hbox pp () ;
for _ = 0 to !indent do
Format.pp_print_space pp ()
done ;
Format.fprintf pp "%d-%s@." !indent step ;
Format.pp_close_box pp () ;
let subtree = Lwt_main.run (Store.Tree.list node []) in
draw_levels subtree pp ;
Format.pp_close_box pp () )
tree ;
indent := !indent - 1 in
let root =
Lwt_main.run
(Store.get_tree r.s r.path >>= fun n -> Store.Tree.list n [])
in
Panel.draw_pp height (draw_levels root) s
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)) }
type top =
{ te: Panel.textedit
; res: Format.symbolic_output_buffer
; mutable eval: Topinf.evalenv option
; mutable path: string list
; mutable histpath: string list
; storeview: storeview }
let make_top storepath ?(branch = "current") () =
let t =
{ te= Panel.make_textedit ()
; res= Format.make_symbolic_output_buffer ()
; eval= None
; path= ["init"]
; histpath= ["history"]
; storeview= make_storeview storepath branch () } in
Topinf.ppf := Format.formatter_of_symbolic_output_buffer t.res ;
Format.pp_set_formatter_out_functions Format.std_formatter
(out_funs_of_sob t.res) ;
let zctx = Zed_edit.context t.te.ze t.te.zc in
Zed_edit.insert zctx
(Zed_rope.of_string
(Zed_string.of_utf8
(Lwt_main.run (Store.get t.storeview.s t.path)) ) ) ;
t
let top_panel (t : top) =
let ppf = Format.formatter_of_symbolic_output_buffer t.res in
Topinf.ppf := ppf ;
let eval =
match t.eval with
(* HACK use Lazy.? *)
| None ->
let e =
match !Topinf.eval with
| Some e -> e
| None -> Topinf.init ppf in
t.eval <- Some e ;
e
| Some e -> e in
let eval () =
try
ignore
(Lwt_main.run
( Store.tree t.storeview.s
>>= fun tree ->
Store.Tree.add tree
(t.histpath @ ["input"])
(Panel.str_of_textedit t.te) ) ) ;
ignore (Format.flush_symbolic_output_buffer t.res) ;
eval ppf (Panel.str_of_textedit t.te ^ ";;") ;
(*HACK to prevent getting stuck in parser*)
let b = Buffer.create 69 in
format_symbolic_output_buffer
(Format.formatter_of_buffer b)
(Format.get_symbolic_output_buffer t.res) ;
ignore
(Lwt_main.run
( Store.tree t.storeview.s
>>= fun tree ->
Store.Tree.add tree
(t.histpath @ ["output"])
(Buffer.contents b) ) ) ;
ignore
(Lwt_main.run
(Store.set_exn t.storeview.s
~info:(Irmin_unix.info "history")
t.path
(Panel.str_of_textedit t.te) ) ) ;
Zed_edit.clear_data t.te.ze
with e ->
F.pf ppf "Exception in pane_top//eval@." ;
Location.report_exception ppf e ;
F.epr "Exception in pane_top//eval@." in
t.te.bindings <-
Input.(
Bind.add
[{mods= Keymod.of_list [Ctrl]; code= Enter}]
Bind.[Custom eval]
t.te.bindings) ;
Panel.(
vbox
[ textedit t.te
; prettyprint (fun pp ->
Format.pp_open_hovbox pp 0 ;
format_symbolic_output_buffer pp
(Format.get_symbolic_output_buffer t.res) ;
Format.pp_close_box pp () ;
F.flush pp () ) (*; draw_textedit_input height t.te *) ])
let top_1 = make_top "../rootstore" ()
let () =
let actor =
Panel.actor
(Panel.obox
[ Panel.draw (fun (s : Display.state) ->
(s, Display.fill_box (Display.gray 0.125) s.box) )
; top_panel top_1 ] ) in
Display.(run (make_frame ~title:"hi" ~w:1440 ~h:900 ()) 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